[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Fri Nov 30 16:51:19 UTC 2007
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv2729
Modified Files:
cell-types.lisp cells-manifesto.txt cells.lisp cells.lpr
constructors.lisp defmodel.lisp defpackage.lisp family.lisp
fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp
md-utilities.lisp model-object.lisp propagate.lisp
synapse-types.lisp synapse.lisp test-synapse.lisp trc-eko.lisp
Log Message:
--- /project/cells/cvsroot/cells/cell-types.lisp 2007/01/29 06:43:48 1.25
+++ /project/cells/cvsroot/cells/cell-types.lisp 2007/11/30 16:51:18 1.26
@@ -166,7 +166,7 @@
;__________________
(defmethod c-print-value ((c c-ruled) stream)
- (format stream "~a" (cond ((c-validp c) "<vld>")
+ (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>"))
((c-unboundp c) "<unb>")
((not (c-currentp c)) "dirty")
(t "<err>"))))
--- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/11 22:16:20 1.10
+++ /project/cells/cvsroot/cells/cells-manifesto.txt 2007/11/30 16:51:18 1.11
@@ -181,7 +181,7 @@
is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant
or if it is an input or ruled Cell that never changes value.
-It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion
+It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer execution
until the observed state change has fully propagated; and (b) doing so compromises the declarative
quality of an application -- one can no longer look to one rule to see how a slot (in this case the
input slot being assigned by the observer) gets its value. A reasonable usage might be one with
@@ -205,8 +205,8 @@
by the change to X and will not be recomputed.
- recomputations, when they read other datapoints, must see only values current with the new value of X.
- Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from
- the new value of X.
+ Example: if A depends on B and X, and B depends on X, when X changes and A reads B and X to compute a
+ new value, B must return a value recomputed from the new value of X.
- similarly, client observer callbacks must see only values current with the new value of X; and
@@ -285,11 +285,19 @@
to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo
CLOS instance data into, say, SQL tables.
-Prior Art
+Prior Art (in increasing order of priorness (age))
---------
+Functional reactive programming:
+ This looks to be the most active, current, and vibrant subset of folks working on this sort of stuff.
+ Links:
+ FlapJax (FRP-powered web apps) http://www.flapjax-lang.org/
+ http://lambda-the-ultimate.org/node/1771
+ http://www.haskell.org/frp/
+ FrTime (scheme FRP implementation, no great links) http://pre.plt-scheme.org/plt/collects/frtime/doc.txt
+
Adobe Adam, originally developed only to manage complex GUIs. [Adam]
-COSI, a class-based Cells-alike used at STSCI to in software used to
+COSI, a class-based Cells-alike used at STSCI in software used to
schedule Hubble telescope viewing time. [COSI]
Garnet's KR: http://www.cs.cmu.edu/~garnet/
@@ -304,13 +312,12 @@
http://www.cs.utk.edu/~bvz/quickplan.html
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
-Steele himself cites Sketchpad as inexlicably unappreciated prior
+Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
See also:
The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
- Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf
Frame-based programming
Definitive-programming
--- /project/cells/cvsroot/cells/cells.lisp 2007/01/29 06:43:52 1.20
+++ /project/cells/cvsroot/cells/cells.lisp 2007/11/30 16:51:18 1.21
@@ -19,8 +19,12 @@
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+
+
(in-package :cells)
+
+
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
@@ -32,6 +36,9 @@
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
+#+test
+(cells-reset)
+
(defun cells-reset (&optional client-queue-handler &key debug)
(utils-kt-reset)
(setf
@@ -55,6 +62,11 @@
(defun c-stopped ()
*stop*)
+(export! .stopped)
+
+(define-symbol-macro .stopped
+ (c-stopped))
+
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
(declare (ignorable assertion places fmt$ fmt-args))
#+(or)`(progn)
--- /project/cells/cvsroot/cells/cells.lpr 2007/01/29 06:43:59 1.27
+++ /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28
@@ -1,8 +1,8 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*-
(in-package :cg-user)
-(defpackage :CELLS)
+(defpackage :cells)
(define-project :name :cells
:modules (list (make-instance 'module :name "defpackage.lisp")
--- /project/cells/cvsroot/cells/constructors.lisp 2007/01/29 06:43:59 1.16
+++ /project/cells/cvsroot/cells/constructors.lisp 2007/11/30 16:51:18 1.17
@@ -26,7 +26,7 @@
(defmacro c-lambda (&body body)
`(c-lambda-var (slot-c) , at body))
-(export! .cache-bound-p)
+(export! .cache-bound-p c?+n)
(defmacro c-lambda-var ((c) &body body)
`(lambda (,c &aux (self (c-model ,c))
@@ -49,6 +49,13 @@
:value-state :unevaluated
:rule (c-lambda , at body)))
+(defmacro c?+n (&body body)
+ `(make-c-dependent
+ :inputp t
+ :code ',body
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
(defmacro c?n (&body body)
`(make-c-dependent
:code '(without-c-dependency , at body)
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/12/12 15:58:42 1.12
+++ /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13
@@ -17,7 +17,6 @@
|#
(in-package :cells)
-
(defmacro defmodel (class directsupers slotspecs &rest options)
;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
(assert (not (find class directsupers))() "~a cannot be its own superclass" class)
@@ -197,3 +196,6 @@
(ddd (c-in nil) :cell :ephemeral)
:superx 42 ;; default-initarg
(:documentation "as if!")))
+
+
+
--- /project/cells/cvsroot/cells/defpackage.lisp 2006/11/04 20:52:01 1.9
+++ /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10
@@ -58,6 +58,6 @@
#:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib
#:not-to-be #:ssibno
#:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff
- )
+ #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx)
#+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc)
)
--- /project/cells/cvsroot/cells/family.lisp 2007/01/29 06:43:59 1.19
+++ /project/cells/cvsroot/cells/family.lisp 2007/11/30 16:51:18 1.20
@@ -28,7 +28,6 @@
(.value :initform nil :accessor value :initarg :value)
(zdbg :initform nil :accessor dbg :initarg :dbg)))
-
(defmethod fm-parent (other)
(declare (ignore other))
nil)
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2007/01/29 06:43:59 1.15
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2007/11/30 16:51:18 1.16
@@ -87,11 +87,11 @@
(or (funcall some-function parent)
(fm-ascendant-some (fm-parent parent) some-function))))
-(defun fm-ascendant-if (self if-function)
- (when (and self if-function)
- (or (when (funcall if-function self)
+(defun fm-ascendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
self)
- (fm-ascendant-if .parent if-function))))
+ (fm-ascendant-if .parent test))))
(defun fm-descendant-if (self test)
(when (and self test)
@@ -105,11 +105,13 @@
(when (fm-includes node d2)
node))))
-(defun fm-collect-if (tree test)
+(defun fm-collect-if (tree test &optional skip-top dependently)
(let (collection)
(fm-traverse tree (lambda (node)
- (when (funcall test node)
- (push node collection))))
+ (unless (and skip-top (eq node tree))
+ (when (funcall test node)
+ (push node collection))))
+ :with-dependency dependently)
(nreverse collection)))
(defun fm-value-dictionary (tree value-fn &optional include-top)
@@ -159,6 +161,39 @@
(without-c-dependency (tv))))))
(values))
+(export! fm-traverse-bf)
+(defun fm-traverse-bf (family applied-fn &optional (cq (make-fifo-queue)))
+ (when family
+ (flet ((process-node (fm)
+ (funcall applied-fn fm)
+ (when (kids fm)
+ (fifo-add cq (kids fm)))))
+ (process-node family)
+ (loop for x = (fifo-pop cq)
+ while x
+ do (mapcar #'process-node x)))))
+
+#+test-bf
+(progn
+ (defmd bftree (family)
+ (depth 0 :cell nil)
+ (id (c? (klin self)))
+ :kids (c? (when (< (depth self) 4)
+ (loop repeat (1+ (depth self))
+ collecting (make-kid 'bftree :depth (1+ (depth self)))))))
+
+ (defun klin (self)
+ (when self
+ (if .parent
+ (cons (kid-no self) (klin .parent))
+ (list 0))))
+
+ (defun test-bf ()
+ (let ((self (make-instance 'bftree)))
+ (fm-traverse-bf self
+ (lambda (node)
+ (print (id node)))))))
+
(defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2)))
(assert top)
(fm-traverse top (lambda (n)
@@ -213,7 +248,7 @@
;; should be modified to go through 'gather', which should be the real fm-find-all
;;
-(export! fm-do-up)
+(export! fm-do-up fm-find-next fm-find-prior)
(defun fm-do-up (self &optional (fn 'identity))
(when self
@@ -554,7 +589,8 @@
(count-it :fm-find-one)
(flet ((matcher (fm)
(when diag
- (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name))
+ (trc nil
+ "fm-find-one matcher sees name" (md-name fm) :ofthing (type-of fm) :seeking md-name global-search))
(when (and (eql (name-root md-name)(md-name fm))
(or (null (name-subscript md-name))
(eql (name-subscript md-name) (fm-pos fm)))
--- /project/cells/cvsroot/cells/integrity.lisp 2007/01/29 06:44:00 1.17
+++ /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 16:51:18 1.18
@@ -44,6 +44,9 @@
*within-integrity*)
(defun call-with-integrity (opcode defer-info action)
+ (when (eq opcode :change)
+ (when (eq defer-info :focus)
+ (break "cwi focus change")))
(when *stop*
(return-from call-with-integrity))
(if *within-integrity*
@@ -76,7 +79,7 @@
(defun ufb-add (opcode continuation)
(assert (find opcode *ufb-opcodes*))
- (when (and *no-tell* (eq opcode :tell-dependents))
+ #+trythis (when (and *no-tell* (eq opcode :tell-dependents))
(break "truly queueing tell under no-tell"))
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
(fifo-add (ufb-queue-ensure opcode) continuation))
@@ -109,27 +112,38 @@
;
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
(trcx finish-business uqp)
- (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
+ (dolist (b (fifo-data (ufb-queue :tell-dependents)))
(trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
(break "unexpected 1> ufb needs to tell dependnents after telling dependents"))
(let ((*no-tell* t))
(just-do-it :awaken) ;--- md-awaken new instances ---
- )
+ )
;
- ; we do not go back to check for a need to :tell-dependents because (a) the original propagation
+ ; OLD THINKING, preserved for the record, but NO LONGER TRUE:
+ ; we do not go back to check for a need to :tell-dependents because (a) the original propagation
; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that
; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during
; awakening need that precisely because no one asked for their values, so there can be no dependents
; to "tell". I think. :) So...
+ ; END OF OLD THINKING
;
+ ; We now allow :awaken to change things so more dependents need to be told. The problem is the implicit
+ ; dependence on the /life/ of a model whenever there is a dependence on any /cell/ of that model.
+ ; md-quiesce currently just flags such slots as uncurrent -- maybe /that/ should change and those should
+ ; recalculate at once -- and then an /observer/ can run and ask for a new value from such an uncurrent cell,
+ ; which now knows it must recalculate. And that recalculation of course can and likely will come up with a new value
+ ; and perforce need to tell its dependents. So...
+ ;
+ ; I /could/ explore something other than the "uncurrent" kludge, but NCTM 2007 is coming up and
+ ; to be honest the idea of not allowing nested tells was enforcing a /guess/ that that should not
+ ; arise, and there was not even any perceived integrity whole being closed, it was just a gratuitous
+ ; QA trick, and indeed for a long time many nested tells were avoidable. But the case of the quiesced
+ ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
+
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
- (trcx finish-business uqp)
- (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
- (trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
- (break "unexpected 2> ufb needs to tell dependnents after awakening"))
-
- (assert (null (fifo-peek (ufb-queue :tell-dependents))))
-
+ (trc "retelling dependenst, one new one being" uqp)
+ (go tell-dependents))
+
;--- process client queue ------------------------------
;
(when *stop* (return-from finish-business))
@@ -141,7 +155,7 @@
(just-do-it clientq))
(when (fifo-peek (ufb-queue :client))
#+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry)
- (trc "surprise client" entry)))
+ (trc "surprise client" entry)))
(go handle-clients)))
;--- now we can reset ephemerals --------------------
;
--- /project/cells/cvsroot/cells/link.lisp 2007/01/29 06:44:01 1.23
+++ /project/cells/cvsroot/cells/link.lisp 2007/11/30 16:51:18 1.24
@@ -67,7 +67,8 @@
(zerop (sbit usage rpos)))
(progn
(count-it :unlink-unused)
- (trc nil "c-unlink-unused" c :dropping-used (car useds))
+ #+save (when (eq 'mathx::progress (c-slot-name c))
+ (trc "c-unlink-unused" c :dropping-used (car useds)) )
(c-unlink-caller (car useds) c)
(rplaca useds nil))
(progn
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/01/29 06:44:01 1.34
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 16:51:18 1.35
@@ -64,6 +64,8 @@
;;; (mathx::show-time t)
;;; (ctk::app-time t))))
+(defvar *trc-ensure* nil)
+
(defun ensure-value-is-current (c debug-id ensurer)
;
; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure
@@ -78,7 +80,7 @@
(cond
((c-currentp c)
- (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
+ (trc nil "EVIC yep: c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
;;
((and (c-inputp c)
@@ -100,15 +102,23 @@
(or (check-reversed (cdr useds))
(let ((used (car useds)))
(ensure-value-is-current used :nested c)
- (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
+ #+slow (trc c "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
(when (> (c-pulse-last-changed used)(c-pulse c))
- (trc nil "used changed and newer !!!!!!" c debug-id used)
+ #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used))
+ #+shhh (when (trcp c)
+ (describe used))
t))))))
(assert (typep c 'c-dependent))
(check-reversed (cd-useds c))))
- (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*)
+ #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*)
(calculate-and-set c))
+ ((mdead (c-value c))
+ (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
+ (let ((new-v (calculate-and-set c)))
+ (trc "ensure-value-is-current> GOT new value ~a" new-v)))
+
(t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
(c-pulse-update c :valid-uninfluenced)))
@@ -118,7 +128,7 @@
(bwhen (v (c-value c))
(if (mdead v)
(progn
- (trc "ensure-value not returning dead model object value" v)
+ (brk "ensure-value still got and still not returning ~a dead value ~a" c v)
nil)
v)))
@@ -127,7 +137,8 @@
(when (c-stopped)
(princ #\.)
(return-from calculate-and-set))
-
+
+ #-its-alive!
(bwhen (x (find c *call-stack*)) ;; circularity
(unless nil ;; *stop*
(let ((stack (copy-list *call-stack*)))
@@ -142,7 +153,7 @@
(setf caller-reiterated (eq caller c)))
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)" c)
- (break))
+ (break "see listener for cell rule cycle diagnotics"))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
@@ -160,7 +171,7 @@
(let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
(assert (typep c 'c-ruled))
- (trc nil "calculate-and-link" c)
+ #+slow (trc *c-debug* "calculate-and-link" c)
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
@@ -248,7 +259,7 @@
; --- head off unchanged; this got moved earlier on 2006-06-10 ---
(when (and (not (eq propagation-code :propagate))
- (eql prior-state :valid)
+ (find prior-state '(:valid :uncurrent))
(c-no-news c absorbed-value prior-value))
(trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
(count-it :nonews)
@@ -303,16 +314,23 @@
(setf (c-state c) :optimized-away)
- (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
+ (let ((entry (rassoc c (cells (c-model c)))))
(unless entry
(describe c))
(c-assert entry)
(trc nil "c-optimize-away?! moving cell to flushed list" c)
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
- (push entry (cells-flushed (c-model c))))
+ #-its-alive! (push entry (cells-flushed (c-model c)))
+ )
(dolist (caller (c-callers c))
- (break "got opti of called")
+ ;
+ ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
+ ; kicked off and asked about the value of a dead instance. That returns nil, and
+ ; there was no other dependency, so the Cell then decided to optimize itself away.
+ ; of course, before that time it had a normal value on which other things depended,
+ ; so we ended up here. where there used to be a break.
+ ;
(setf (cd-useds caller) (delete c (cd-useds caller)))
(c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)))
--- /project/cells/cvsroot/cells/md-utilities.lisp 2007/01/29 06:44:01 1.12
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2007/11/30 16:51:18 1.13
@@ -33,7 +33,7 @@
(defgeneric mdead (self)
(:method ((self model-object))
- (eq :eternal-rest (md-state SELF)))
+ (eq :eternal-rest (md-state self)))
(:method (self)
(declare (ignore self))
@@ -47,19 +47,19 @@
(:method :around ((self model-object))
(declare (ignorable self))
(trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
- "not-to-be nailing" self)
- (c-assert (not (eq (md-state self) :eternal-rest)))
+ "not.to-be nailing" self)
+ ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest)))
+ (unless (eq (md-state self) :eternal-rest)
+ (call-next-method)
+
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
+
+ (md-map-cells self nil
+ (lambda (c)
+ (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
- (call-next-method)
-
- (setf (fm-parent self) nil
- (md-state self) :eternal-rest)
-
- (md-map-cells self nil
- (lambda (c)
- (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc)
-
- (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)))
+ (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
@@ -75,13 +75,11 @@
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
- (trc nil "c-quiesce unlinking caller" c)
+ (trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
-
-
(defparameter *to-be-dbg* nil)
(defmacro make-kid (class &rest initargs)
--- /project/cells/cvsroot/cells/model-object.lisp 2007/01/29 06:44:01 1.15
+++ /project/cells/cvsroot/cells/model-object.lisp 2007/11/30 16:51:18 1.16
@@ -143,8 +143,11 @@
;; next is an indirect and brittle way to determine that a slot has already been output,
;; but I think anything better creates a run-time hit.
;;
- (unless (md-slot-cell-flushed self slot-name) ;; slot will have been propagated just after cell was flushed
- (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))
+ ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
+ ;; but first I worried about it being slow keeping the flushed list /and/ searching, then
+ ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
+ (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
+
((find (c-lazy c) '(:until-asked :always t))
(trc nil "md-awaken deferring c-awaken since lazy"
@@ -224,9 +227,6 @@
(setf (slot-value self slot-name) new-value)
(setf (symbol-value slot-name) new-value)))
-(defun md-slot-cell-flushed (self slot-name)
- (cdr (assoc slot-name (cells-flushed self))))
-
;----------------- navigation: slot <> initarg <> esd <> cell -----------------
#+cmu
--- /project/cells/cvsroot/cells/propagate.lisp 2007/01/29 06:44:01 1.27
+++ /project/cells/cvsroot/cells/propagate.lisp 2007/11/30 16:51:18 1.28
@@ -46,7 +46,8 @@
(defun c-pulse-update (c key)
(declare (ignorable key))
- (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c))
+ (unless (find key '(:valid-uninfluenced))
+ (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)))
(assert (>= *data-pulse-id* (c-pulse c)) ()
"Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c)
(setf (c-pulse c) *data-pulse-id*))
@@ -74,7 +75,7 @@
(princ #\.)(princ #\!)
(return-from c-propagate))
(trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
- (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
+ #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
(trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
@@ -83,7 +84,7 @@
; --- manifest new value as needed ---
;
- ; 20061030 Trying not-to-be first because doomed instances may be interested in callers
+ ; 20061030 Trying not.to.be first because doomed instances may be interested in callers
; who will decide to propagate. If a family instance kids slot is changing, a doomed kid
; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid
; to look at its siblings (say a view instance being deleted from a stack who looks to the psib
@@ -95,7 +96,7 @@
(md-slot-owning (type-of (c-model c)) (c-slot-name c)))
(trc nil "c-propagate> contemplating lost")
(flet ((listify (x) (if (listp x) x (list x))))
- (bIf (lost (set-difference (listify prior-value) (listify (c-value c))))
+ (bif (lost (set-difference (listify prior-value) (listify (c-value c))))
(progn
(trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c))
(mapcar 'not-to-be lost))
@@ -169,6 +170,8 @@
; --- recalculate dependents ----------------------------------------------------
+
+
(defun c-propagate-to-callers (c)
;
; We must defer propagation to callers because of an edge case in which:
@@ -186,26 +189,27 @@
(member (c-lazy caller) '(t :always :once-asked))))
(c-callers c))
(let ((causation (cons c *causation*))) ;; in case deferred
- (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c))
+ #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
(trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c))
#+c-debug (dolist (caller (c-callers c))
(assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
- (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
- (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
- (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
- (member (c-lazy caller) '(t :always :once-asked)))
- (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
- ))
+ #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
+ (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
+ ))
(dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list...
(trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
(unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
(member (c-lazy caller) '(t :always :once-asked)))
(assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c)
- (trc nil "propagating to caller is used" c :caller caller)
- (ensure-value-is-current caller :prop-from c))))))))
+ #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c))
+ (let ((*trc-ensure* (trcp c)))
+ (ensure-value-is-current caller :prop-from c)))))))))
--- /project/cells/cvsroot/cells/synapse-types.lisp 2006/05/20 06:32:19 1.5
+++ /project/cells/cvsroot/cells/synapse-types.lisp 2007/11/30 16:51:18 1.6
@@ -18,6 +18,18 @@
(in-package :cells)
+(export! f-find)
+
+(defmacro f-find (synapse-id sought where)
+ `(call-f-find ,synapse-id ,sought ,where))
+
+(defun call-f-find (synapse-id sought where)
+ (with-synapse synapse-id ()
+ (bif (k (progn
+ (find sought where)))
+ (values k :propagate)
+ (values nil :no-propagate))))
+
(defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body)
`(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () , at body)))
--- /project/cells/cvsroot/cells/synapse.lisp 2006/07/24 05:03:08 1.14
+++ /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15
@@ -19,7 +19,7 @@
(in-package :cells)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent)))
+ (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse)))
(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
(let ((syn-id (gensym))(syn-caller (gensym)))
@@ -40,7 +40,6 @@
(multiple-value-bind (v p)
(with-integrity ()
(ensure-value-is-current synapse :synapse (car *call-stack*)))
- (trc nil "with-synapse: synapse, v, prop" synapse v p)
(values v p))
(record-caller synapse)))))
--- /project/cells/cvsroot/cells/test-synapse.lisp 2005/12/09 18:59:33 1.1
+++ /project/cells/cvsroot/cells/test-synapse.lisp 2007/11/30 16:51:18 1.2
@@ -35,6 +35,7 @@
(print `(output m-syn-b ,self ,new-value ,old-value)))
+
(def-cell-test m-syn
(progn (cell-reset)
(let* ((delta-ct 0)
--- /project/cells/cvsroot/cells/trc-eko.lisp 2007/01/29 06:44:01 1.6
+++ /project/cells/cvsroot/cells/trc-eko.lisp 2007/11/30 16:51:18 1.7
@@ -22,8 +22,6 @@
(defparameter *trcdepth* 0)
-(export! trc wtrc eko)
-
(defun trcdepth-reset ()
(setf *trcdepth* 0))
@@ -35,18 +33,31 @@
`(without-c-dependency
(call-trc t ,tgt-form , at os))
(let ((tgt (gensym)))
+ ;(break "slowww? ~a" tgt-form)
`(without-c-dependency
(bif (,tgt ,tgt-form)
(if (trcp ,tgt)
(progn
- (assert (stringp ,(car os)))
+ (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os))
(call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
(progn
- ;; (break "trcfailed")
+ ;(trc "trcfailed")
(count-it :trcfailed)))
(count-it :tgtnileval)))))))
-(export! trcx)
+(export! brk brkx .bgo)
+
+
+(define-symbol-macro .bgo (break "go"))
+
+(defun brk (&rest args)
+ #+its-alive! (print args)
+ #-its-alive! (progn
+ ;;(setf *ctk-dbg* t)
+ (apply 'break args)))
+
+(defmacro brkx (msg)
+ `(break "At ~a: OK?" ',msg))
(defmacro trcx (tgt-form &rest os)
(if (eql tgt-form 'nil)
@@ -60,6 +71,7 @@
(defparameter *last-trc* (get-internal-real-time))
(defun call-trc (stream s &rest os)
+ ;(break)
(if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
*trcdepth*)
(format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
@@ -85,8 +97,6 @@
(defmethod trcp :around (other)
(unless (call-next-method other)(break)))
-(export! trcp)
-
(defmethod trcp (other)
(eq other t))
@@ -99,8 +109,6 @@
(defun trcdepth-decf ()
(format t "decrementing trc depth ~d" *trcdepth*)
(decf *trcdepth*))
-
-(export! wtrc eko-if)
(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
`(let ((*trcdepth* (if *trcdepth*
@@ -121,11 +129,12 @@
;------ eko --------------------------------------
-
(defmacro eko ((&rest trcargs) &rest body)
(let ((result (gensym)))
`(let ((,result , at body))
- (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ ,(if (stringp (car trcargs))
+ `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs)))
,result)))
(defmacro ekx (ekx-id &rest body)
@@ -134,8 +143,6 @@
(trc ,(string-downcase (symbol-name ekx-id)) :=> ,result)
,result)))
-(export! ekx)
-
(defmacro eko-if ((&rest trcargs) &rest body)
(let ((result (gensym)))
`(let ((,result , at body))
@@ -148,4 +155,5 @@
`(let ((,result (, at body)))
(when ,label
(trc ,label ,result))
- ,result)))
\ No newline at end of file
+ ,result)))
+
More information about the Cells-cvs
mailing list