Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv3722 Modified Files: cells.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp Log Message: Restore rough tracking of propagation (search for *cause*) Date: Thu May 26 03:15:50 2005 Author: ktilton Index: cells/cells.lisp diff -u cells/cells.lisp:1.3 cells/cells.lisp:1.4 --- cells/cells.lisp:1.3 Wed May 18 23:47:29 2005 +++ cells/cells.lisp Thu May 26 03:15:50 2005 @@ -30,6 +30,7 @@ (define-constant *c-optimizep* t) (defparameter *c-prop-depth* 0) +(defparameter *causation* nil) (defparameter *data-pulse-id* 0) (defparameter *data-pulses* nil) @@ -88,6 +89,9 @@ (defmacro without-c-dependency (&body body) `(let (*c-calculators*) ,@body)) + +(define-symbol-macro .cause + (car *causation*)) (define-condition unbound-cell (unbound-slot) ()) Index: cells/link.lisp diff -u cells/link.lisp:1.4 cells/link.lisp:1.5 --- cells/link.lisp:1.4 Sat May 21 17:13:12 2005 +++ cells/link.lisp Thu May 26 03:15:50 2005 @@ -62,7 +62,7 @@ (count-it :new-used) (incf useds-len) (setf used-pos 0) - (push user (c-users used)) + ;; 050525kt - wait till eval completes (push user (c-users used)) (push used (cd-useds user))) (let ((mapn (- *cd-usagect* @@ -104,7 +104,7 @@ (loop for useds on (cd-useds c) for used = (car useds) for mapn upfrom (- *cd-usagect* (length (cd-useds c))) - when (zerop (sbit usage mapn)) + if (zerop (sbit usage mapn)) do (c-assert (not (minusp mapn))) (c-assert (< mapn *cd-usagect*)) @@ -112,7 +112,9 @@ (trc nil "dropping unused" used :mapn-usage mapn usage) (count-it :unlink-unused) (c-unlink-user used c) - (rplaca useds nil)) + (rplaca useds nil) + else do (pushnew c (c-users used)) ;; 050525 deferred from c-link-ex + ) (setf (cd-useds c) (delete-if #'null (cd-useds c)))) (defun c-user-path-exists-p (from-used to-user) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.8 cells/md-slot-value.lisp:1.9 --- cells/md-slot-value.lisp:1.8 Sat May 21 17:13:12 2005 +++ cells/md-slot-value.lisp Thu May 26 03:15:50 2005 @@ -132,8 +132,10 @@ (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) nil prior-value :makunbound)) - (with-integrity (:makunbound :makunbound c) - (c-propagate c prior-value t))))) + (let ((causation *causation*)) + (with-integrity (:makunbound :makunbound c) + (let ((*causation* causation)) + (c-propagate c prior-value t))))))) (defun (setf md-slot-value) (new-value self slot-name &aux (c (md-slot-cell self slot-name))) @@ -147,11 +149,13 @@ (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" slot-name self)) - (with-integrity (:setf :setf c new-value) - (trc nil "(setf md-slot-value) calling assume" c new-value) - (md-slot-value-assume c new-value nil)) + (let ((causation *causation*)) + (with-integrity (:setf :setf c new-value) + (let ((*causation* causation)) + (trc nil "(setf md-slot-value) calling assume" c new-value) + (md-slot-value-assume c new-value nil)) - new-value) + new-value))) Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.7 cells/propagate.lisp:1.8 --- cells/propagate.lisp:1.7 Wed May 25 07:04:46 2005 +++ cells/propagate.lisp Thu May 26 03:15:50 2005 @@ -58,8 +58,10 @@ (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c) - (with-integrity (:user-notify :user-notify c) - (progn + (let ((causation (cons c *causation*))) ;; in case deferred + (with-integrity (:user-notify :user-notify c) + (assert (null *c-calculators*)) + (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) (bwhen (dead (catch :mdead @@ -71,7 +73,7 @@ (when (eq dead (c-model c)) (trc nil "!!! aborting further user prop of dead" dead) (return-from c-propagate-to-users)) - (trc nil "!!! continuing user prop following: user => dead" user dead)))))) + (trc nil "!!! continuing user prop following: user => dead" user dead))))))) (defun c-user-cares (c) (not (or (c-currentp c) @@ -81,15 +83,17 @@ (getf (symbol-plist slot-name) :output-defined)) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (with-integrity (:c-output-slot :output c) - (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) - ;; (count-it :output slot-name) - (c-output-slot-name slot-name - self - new-value - prior-value - prior-value-supplied) - (c-ephemeral-reset c))) + (let ((causation *causation*)) ;; in case deferred + (with-integrity (:c-output-slot :output c) + (let ((*causation* causation)) + (trc nil "c-output-slot > now!!" self slot-name new-value prior-value) + ;; (count-it :output slot-name) + (c-output-slot-name slot-name + self + new-value + prior-value + prior-value-supplied) + (c-ephemeral-reset c))))) (defun c-ephemeral-reset (c) (when c Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.5 cells/synapse.lisp:1.6 --- cells/synapse.lisp:1.5 Wed May 25 07:04:46 2005 +++ cells/synapse.lisp Thu May 26 03:15:50 2005 @@ -27,18 +27,20 @@ (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (declare (ignorable trcp)) - (let ((syn-id (gensym))) + (let ((syn-id (gensym))(syn-user (gensym))) `(let* ((,syn-id (eko ("!!! syn-id =") ,synapse-id)) - (synapse-user (car *c-calculators*)) - (synapse (or (bIf (ku (find ,syn-id (cd-useds synapse-user) :key 'c-slot-name)) - (progn - (trc "withsyn reusing known" ,syn-id ku) - ku)) + (,syn-user (car *c-calculators*)) + (synapse (or (find ,syn-id (cd-useds ,syn-user) :key 'c-slot-name) (let ((new-syn (let (,@closure-vars) (trc "withsyn making new syn" ,syn-id - :known (mapcar 'c-slot-name (cd-useds synapse-user))) - (make-synaptic-ruled ,syn-id synapse-user ,@body)))) + :known (mapcar 'c-slot-name (cd-useds ,syn-user))) + (make-c-dependent + :model (c-model ,syn-user) + :slot-name ,syn-id + :code ',body + :synaptic t + :rule (c-lambda ,@body))))) (c-link-ex new-syn) new-syn)))) (prog1