[cells-cvs] CVS update: cells/cells.lisp cells/link.lisp cells/md-slot-value.lisp cells/propagate.lisp cells/synapse.lisp
Kenny Tilton
ktilton at common-lisp.net
Thu May 26 01:15:52 UTC 2005
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*) , at 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 (, at 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 , at 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 , at body)))))
(c-link-ex new-syn)
new-syn))))
(prog1
More information about the Cells-cvs
mailing list