[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