[cells-cvs] CVS cells

ktilton ktilton at common-lisp.net
Fri Nov 30 16:51:19 UTC 2007


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




More information about the Cells-cvs mailing list