[cells-cvs] CVS cells

[ktilton]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv7851

Modified Files:
	cell-types.lisp cells.lisp md-slot-value.lisp 
	optimization.lisp 
Log Message:
Most interesting, sloght change to md-slot-value-assume, to abort unchanged assignment a whisker sooner.

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/05/20 06:32:19	1.9
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/10 22:16:35	1.10
@@ -103,40 +103,6 @@
   (usage (make-array 16 :element-type 'bit
                         :initial-element 0) :type simple-bit-vector))
 
-
-(defstruct (c-stream
-            (:include c-dependent)
-            (:conc-name cs-))
-  values)
-
-(defstruct streamer from stepper donep to)
-
-#+(or)
-(defmacro c~~~ (&key (from 0)
-                 stepper
-                 (donep (c-lambda (> .cache (streamer-to slot-c))))
-                 to)
-   `(make-c-stream
-     :rule (c-lambda (make-streamer
-                      :from ,from
-                      :stepper ,stepper
-                      :to ,to :donep ,donep))))
-
-;;;(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
-;;;  (bif (to (streamer-to s))
-;;;    (loop for slot-value = (streamer-from s)
-;;;          then (bif (stepper (streamer-stepper s))
-;;;                 (funcall stepper c)
-;;;                 (incf slot-value))
-;;;          until (bif (to (streamer-to s))
-;;;                  (> slot-value to)
-;;;                  (bwhen (donep-test (streamer-donep s))
-;;;                    (funcall donep-test c)))
-;;;          do (progn
-;;;               (print `(assume doing ,slot-value))
-;;;               (call-next-method c slot-value))))
-;;;  (c-optimize-away?! c))
-
 (defstruct (c-drifter
             (:include c-dependent)))
 
--- /project/cells/cvsroot/cells/cells.lisp	2006/06/03 00:38:04	1.11
+++ /project/cells/cvsroot/cells/cells.lisp	2006/06/10 22:16:35	1.12
@@ -81,7 +81,8 @@
 (define-symbol-macro .cause
     (car *causation*))
 
-(define-condition unbound-cell (unbound-slot) ())
+(define-condition unbound-cell (unbound-slot)
+  ((cell :initarg :cell :reader cell :initform nil)))
 
 (defgeneric slot-value-observe (slotname self new old old-boundp)
   #-(or cormanlisp)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/07 22:12:55	1.17
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/10 22:16:35	1.18
@@ -70,7 +70,7 @@
    (t (c-pulse-update c :valid-uninfluenced)))
 
   (when (c-unboundp c)
-    (error 'unbound-cell :instance (c-model c) :name (c-slot-name c)))
+    (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
 
   (c-value c))
 
@@ -141,7 +141,7 @@
           (without-c-dependency
               (c-propagate c prior-value t)))))))
 
-;;; --- setf md-slot-value --------------------------------------------------------
+;;; --- setf md.slot.value --------------------------------------------------------
 ;;;
 
 (defun (setf md-slot-value) (new-value self slot-name
@@ -176,35 +176,33 @@
       (let ((prior-state (c-value-state c))
             (prior-value (c-value c))
             (absorbed-value (c-absorb-value c raw-value)))
-        
+
+        (c-pulse-update c :slotv-assume)
+
+        ; --- head off unchanged; this got moved earlier on 2006-06-10 ---
+        (when (and (not (eq propagation-code :propagate))
+                (eql prior-state :valid)
+                (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)
+          (return-from md-slot-value-assume absorbed-value))
+
         ; --- slot maintenance ---
         (unless (c-synaptic c)
           (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
         
         ; --- cell maintenance ---
-        (c-pulse-update c :slotv-assume)
         (setf
          (c-value c) absorbed-value
          (c-value-state c) :valid
          (c-state c) :awake)
         
-        (unless (typep c 'c-stream) ;; c-stream (actually a FNYI) needs to run out first stream at least
-          (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
-        
+        (c-optimize-away?! c) ;;; put optimize test here to avoid needless linking
         
         ; --- data flow propagation -----------
-        ;
-        (trc nil "md-sv testing propagation" c propagation-code prior-state absorbed-value prior-value)
-        (if (or (eq propagation-code :no-propagate) ;; possible if c is a cell serving as a synapse between two cells
-              (and (not (eq propagation-code :propagate))
-                (eql prior-state :valid)
-                (c-no-news c absorbed-value prior-value)))
-            (progn
-              (trc nil "(setf md-slot-value) >no news" prior-state (c-no-news c absorbed-value prior-value))
-              (count-it :nonews))
-          (progn
-            (setf (c-changed c) t)
-            (c-propagate c prior-value (eq prior-state :valid))))  ;; until 06-02-13 was (not (eq prior-state :unbound))
+        (unless (eq propagation-code :no-propagate)
+          (setf (c-changed c) t)
+          (c-propagate c prior-value (eq prior-state :valid)))  ;; until 06-02-13 was (not (eq prior-state :unbound))
         
         absorbed-value)))
 
--- /project/cells/cvsroot/cells/optimization.lisp	2006/05/20 06:32:19	1.6
+++ /project/cells/cvsroot/cells/optimization.lisp	2006/06/10 22:16:35	1.7
@@ -27,7 +27,7 @@
   (typecase c
     (c-dependent
      (if (and *c-optimizep*
-           (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away
+           (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
            (c-validp c)
            (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
            ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))