[cells-cvs] CVS cells

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) ,@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 ,@body)))

+(defmacro c?+n (&body body) + `(make-c-dependent + :inputp t + :code ',body + :value-state :unevaluated + :rule (c-lambda ,@body))) + (defmacro c?n (&body body) `(make-c-dependent :code '(without-c-dependency ,@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 () ,@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 ,@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 ,@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 ,@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 ,@body)) @@ -148,4 +155,5 @@ `(let ((,result (,@body))) (when ,label (trc ,label ,result)) - ,result))) \ No newline at end of file + ,result))) +