Update of /project/cells/cvsroot/cells
In directory common-lisp.net:/tmp/cvs-serv29834
Modified Files:
cell-types.lisp cells.lisp constructors.lisp defpackage.lisp
family.lisp integrity.lisp link.lisp md-slot-value.lisp
model-object.lisp optimization.lisp propagate.lisp
synapse.lisp test.lisp
Log Message:
Speed up c-link-ex a little
Date: Wed May 18 23:47:29 2005
Author: ktilton
Index: cells/cell-types.lisp
diff -u cells/cell-types.lisp:1.2 cells/cell-types.lisp:1.3
--- cells/cell-types.lisp:1.2 Sun May 8 01:12:40 2005
+++ cells/cell-types.lisp Wed May 18 23:47:29 2005
@@ -28,7 +28,6 @@
value
inputp ;; t for old c-variable class
- cyclicp ;; t if OK for setf to cycle back (ending cycle)
synaptic
changed
(users nil :type list)
@@ -73,7 +72,7 @@
(defstruct (c-dependent
(:include c-ruled)
(:conc-name cd-))
- (synapses nil :type list)
+ ;; chop (synapses nil :type list)
(useds nil :type list)
(usage (make-array *cd-usagect* :element-type 'bit
:initial-element 0) :type vector))
@@ -99,10 +98,10 @@
(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))
+ then (bif (stepper (streamer-stepper s))
(funcall stepper c)
(incf slot-value))
- until (bIf (to (streamer-to s))
+ until (bif (to (streamer-to s))
(> slot-value to)
(bwhen (donep-test (streamer-donep s))
(funcall donep-test c)))
Index: cells/cells.lisp
diff -u cells/cells.lisp:1.2 cells/cells.lisp:1.3
--- cells/cells.lisp:1.2 Sun May 8 14:42:12 2005
+++ cells/cells.lisp Wed May 18 23:47:29 2005
@@ -57,7 +57,8 @@
*stop*)
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
- (declare (ignore places))
+ (declare (ignorable assertion places fmt$ fmt-args))
+ `(progn) #+not
`(unless *stop*
(unless ,assertion
,(if fmt$
Index: cells/constructors.lisp
diff -u cells/constructors.lisp:1.2 cells/constructors.lisp:1.3
--- cells/constructors.lisp:1.2 Sun May 8 14:42:12 2005
+++ cells/constructors.lisp Wed May 18 23:47:29 2005
@@ -33,6 +33,12 @@
(declare (ignorable .cache self))
,@body))
+(defmacro with-c-cache ((fn) &body body)
+ (let ((new (gensym)))
+ `(or (bwhen (,new (progn ,@body))
+ (funcall ,fn ,new .cache))
+ .cache)))
+
;-----------------------------------------
(defmacro c? (&body body)
@@ -41,12 +47,6 @@
:value-state :unevaluated
:rule (c-lambda ,@body)))
-(defmacro c?8 (&body body)
- `(make-c-dependent
- :code ',body
- :cyclicp t
- :value-state :unevaluated
- :rule (c-lambda ,@body)))
(defmacro c?dbg (&body body)
`(make-c-dependent
@@ -98,13 +98,6 @@
(defmacro c-in (value)
`(make-cell
:inputp t
- :value-state :valid
- :value ,value))
-
-(defmacro c-in8 (value)
- `(make-cell
- :inputp t
- :cyclicp t
:value-state :valid
:value ,value))
Index: cells/defpackage.lisp
diff -u cells/defpackage.lisp:1.2 cells/defpackage.lisp:1.3
--- cells/defpackage.lisp:1.2 Sun May 8 14:42:12 2005
+++ cells/defpackage.lisp Wed May 18 23:47:29 2005
@@ -47,7 +47,7 @@
(:export #:cell #:c-input #:c-in #:c-in8
#:c-formula #:c? #:c?8 #:c?_ #:c??
#:with-integrity #:with-deference #:without-c-dependency #:self
- #:.cache #:c-lambda
+ #:.cache #:.with-c-cache #:c-lambda
#:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test
#:new-value #:old-value #:old-value-boundp #:c...
#:make-be
Index: cells/family.lisp
diff -u cells/family.lisp:1.1 cells/family.lisp:1.2
--- cells/family.lisp:1.1 Fri May 6 23:05:45 2005
+++ cells/family.lisp Wed May 18 23:47:29 2005
@@ -67,18 +67,7 @@
))
(defmacro the-kids (&rest kids)
- `(packed-flat! ,@(mapcar (lambda (kid)
- (typecase kid
- (keyword `(make-instance ',(intern$ (symbol-name kid))))
- (t `,kid)))
- kids)))
-
-(defmacro the-kids-2 (&rest kids)
- `(packed-flat! ,@(mapcar (lambda (kid)
- (typecase kid
- (keyword `(make-instance ',(intern$ (symbol-name kid))))
- (t `,kid)))
- kids)))
+ `(packed-flat! ,@kids))
(defun kid1 (self) (car (kids self)))
(defun last-kid (self) (last1 (kids self)))
@@ -120,6 +109,7 @@
(let ((curr-parent (fm-parent self))
(selftype (type-of self)))
+ (declare (ignorable curr-parent))
(c-assert (or (null curr-parent)
(eql fm-parent curr-parent)))
(when (plusp (adopt-ct self))
Index: cells/integrity.lisp
diff -u cells/integrity.lisp:1.2 cells/integrity.lisp:1.3
--- cells/integrity.lisp:1.2 Sun May 8 14:42:12 2005
+++ cells/integrity.lisp Wed May 18 23:47:29 2005
@@ -118,7 +118,7 @@
(when user-q-item
(destructuring-bind (defer-info . task) user-q-item
(declare (ignorable defer-info))
- (trc nil "finbiz notifying users of cell" (car defer-info))
+ (trc nil "finbiz notifying users of cell" (car defer-info) (cd-users (car defer-info)))
(funcall task)
(go notify-users))))
@@ -127,13 +127,13 @@
next-output
(when *stop* (return-from finish-business))
;--- do c-output-slot-name -----------------------
- (setf task (cdr (fifo-pop (ufb-queue :output))))
+ (setf task (fifo-pop (ufb-queue :output)))
(cond
(task
(setf some-output t)
- (trc nil "finish-business outputting------------------------")
- (funcall task)
+ (trc nil "finish-business outputting--------" (car task))
+ (funcall (cdr task))
(go next-output))
(some-output
(go notify-users)))
Index: cells/link.lisp
diff -u cells/link.lisp:1.1 cells/link.lisp:1.2
--- cells/link.lisp:1.1 Fri May 6 23:05:45 2005
+++ cells/link.lisp Wed May 18 23:47:29 2005
@@ -22,9 +22,6 @@
(in-package :cells)
-
-
-
(defun c-link-ex (used &aux (user (car *c-calculators*)))
(c-assert user)
(assert used)
@@ -46,15 +43,33 @@
(c-assert (not (eq :eternal-rest (md-state (c-model used)))))
(count-it :c-link-entry)
-
- (unless (find used (c-useds user))
- (trc nil "c-link > new user,used " user used)
- (c-add-user used user)
- (c-add-used user used))
-
- (let ((mapn (- *cd-usagect*
- (- (length (cd-useds user))
- (or (position used (cd-useds user)) 0)))))
+;;; (loop for ku in (c-usesds user)
+;;; for posn upfrom 0
+;;; wh
+
+;;; (loop with prior-used = 0
+;;; and found = nil
+;;; for known-used in (c-useds user)
+;;; when (eq known-used used)
+;;; do (progn
+;;; (setf found t)
+;;; (loop-finish))
+;;; finally (return (- *cd-usagect*
+;;; (- (length (cd-useds user))
+;;; (or (position used (cd-useds user)) 0)))))
+
+ (if (find used (c-useds user))
+ (count-it :known-used)
+ (progn
+ (trc nil "c-link > new user,used " user used)
+ (count-it :new-used)
+ (push user (c-users used))
+ (push used (cd-useds user))))
+
+ (let ((mapn (get-mapn used (cd-useds user))
+ #+not (- *cd-usagect*
+ (- (length (cd-useds user))
+ (or (position used (cd-useds user)) 0)))))
;; (trc user "c-link> setting usage bit" user mapn used)
(if (minusp mapn)
(c-break "whoa. more than ~d used by ~a? i see ~d"
@@ -62,6 +77,20 @@
(cd-usage-set user mapn)))
used)
+#+TEST
+(dotimes (n 3)
+ (trc "mapn" n (get-mapn n '(0 1 2))))
+
+(defun get-mapn (seek map)
+ (- *cd-usagect*
+ (loop with seek-pos = nil
+ for m in map
+ for pos upfrom 0
+ counting m into m-len
+ when (eql seek m)
+ do (setf seek-pos pos)
+ finally (return (- m-len seek-pos)))))
+
;--- c-unlink-unused --------------------------------
(defun c-unlink-unused (c &aux (usage (cd-usage c)))
@@ -74,33 +103,17 @@
(c-assert (< mapn *cd-usagect*))
(trc nil "dropping unused" used :mapn-usage mapn usage)
+ (count-it :unlink-unused)
(c-unlink-user used c)
(rplaca useds nil))
(setf (cd-useds c) (delete-if #'null (cd-useds c))))
-(defun c-add-user (used user)
- (count-it :c-adduser)
- (pushnew user (c-users used))
- used)
-
(defun c-user-path-exists-p (from-used to-user)
(count-it :user-path-exists-p)
(or (find to-user (c-users from-used))
(find-if (lambda (from-used-user)
(c-user-path-exists-p from-used-user to-user))
(c-users from-used))))
-
-; -----------
-
-(defun c-add-used (user used)
- (count-it :c-used)
- #+ucount (unless (member used (cd-useds user))
- (incf *cd-useds*)
- (when (zerop (mod *cd-useds* 100))
- (trc "useds count = " *cd-useds*)))
- (pushnew used (cd-useds user))
- (trc nil "c-add-used> user <= used" user used (length (cd-useds user)))
- (cd-useds user))
; ---------------------------------------------
Index: cells/md-slot-value.lisp
diff -u cells/md-slot-value.lisp:1.4 cells/md-slot-value.lisp:1.5
--- cells/md-slot-value.lisp:1.4 Sun May 8 18:47:20 2005
+++ cells/md-slot-value.lisp Wed May 18 23:47:29 2005
@@ -139,8 +139,7 @@
(md-kids-change (c-model c) nil prior-value :makunbound))
(with-integrity (:makunbound :makunbound c)
- (c-propagate c prior-value t)))))
-
+ (c-propagate c prior-value t)))))
(defun (setf md-slot-value) (new-value self slot-name
&aux (c (md-slot-cell self slot-name)))
@@ -186,11 +185,12 @@
; --- data flow propagation -----------
;
+ (trc nil "md-sv comparing" c prior-state absorbed-value prior-value)
(if (and (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 :no-news))
+ (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)
(trc nil "sv-assume: flagging as changed" c absorbed-value prior-value prior-state)
Index: cells/model-object.lisp
diff -u cells/model-object.lisp:1.1 cells/model-object.lisp:1.2
--- cells/model-object.lisp:1.1 Fri May 6 23:05:45 2005
+++ cells/model-object.lisp Wed May 18 23:47:29 2005
@@ -52,6 +52,7 @@
(push (cons slot-name new-type) (get class-name :cell-types)))))
(defmethod md-slot-value-store ((self model-object) slot-name new-value)
+ (trc nil "md-slot-value-store" slot-name new-value)
(setf (slot-value self slot-name) new-value))
(defun md-slot-cell-flushed (self slot-name)
@@ -73,6 +74,7 @@
(defun (setf md-slot-cell) (new-cell self slot-name)
(bif (entry (assoc slot-name (cells self)))
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
+ (declare (ignorable old))
(c-assert (null (c-users old)))
(c-assert (null (cd-useds old)))
(trc nil "replacing in model .cells" old new-cell self)
Index: cells/optimization.lisp
diff -u cells/optimization.lisp:1.3 cells/optimization.lisp:1.4
--- cells/optimization.lisp:1.3 Sun May 8 14:42:12 2005
+++ cells/optimization.lisp Wed May 18 23:47:29 2005
@@ -34,7 +34,7 @@
(not (c-optimized-away-p c)) ;; c-streams 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)
- (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))
+ ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))
(null (cd-useds c)))
(progn
@@ -50,9 +50,8 @@
(dolist (user (c-users c))
(setf (cd-useds user) (delete c (cd-useds user)))
- (trc nil "checking opti2" c :user> user)
- (when (c-optimize-away?! user)
- (trc "Wow!!! optimizing chain reaction, first:" c :then user)))
+ (c-optimize-away?! user) ;; rare but it happens when rule says (or .cache ...)
+ )
t)
(progn
Index: cells/propagate.lisp
diff -u cells/propagate.lisp:1.3 cells/propagate.lisp:1.4
--- cells/propagate.lisp:1.3 Sun May 8 14:42:12 2005
+++ cells/propagate.lisp Wed May 18 23:47:29 2005
@@ -59,13 +59,13 @@
(defun c-propagate-to-users (c)
(trc nil "c-propagate-to-users > queueing" c)
(with-integrity (:user-notify :user-notify c)
- (assert (null *c-calculators*))
(progn
(trc nil "c-propagate-to-users > notifying users of" c)
(dolist (user (c-users c))
(bwhen (dead (catch :mdead
(trc nil "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c)
(when (c-user-cares user)
+ (trc nil "c=prop updating" user :used c)
(c-value-ensure-current user))
nil))
(when (eq dead (c-model c))
@@ -83,7 +83,7 @@
(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)
+ ;; (count-it :output slot-name)
(c-output-slot-name slot-name
self
new-value
Index: cells/synapse.lisp
diff -u cells/synapse.lisp:1.2 cells/synapse.lisp:1.3
--- cells/synapse.lisp:1.2 Sun May 8 01:12:40 2005
+++ cells/synapse.lisp Wed May 18 23:47:29 2005
@@ -28,15 +28,19 @@
(defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body)
(declare (ignorable trcp))
(let ((lex-loc-key (gensym "synapse-id")))
- `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses
- (car *c-calculators*))))
+ `(let ((synapse (or (cdr (assoc ',lex-loc-key
+ (cd-useds (car *c-calculators*))))
(cdar (push (cons ',lex-loc-key
(let (,@closure-vars)
(make-synaptic-ruled slot-c (,fire-p ,fire-value)
,@body)))
- (cd-synapses
+ (cd-useds
(car *c-calculators*)))))))
- (c-value-ensure-current synapse))))
+ (prog1
+ (with-integrity (:with-synapse)
+ (c-value-ensure-current synapse))
+ (when (car *c-calculators*)
+ (c-link-ex synapse))))))
(defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body)
(let ((new-value (gensym))
Index: cells/test.lisp
diff -u cells/test.lisp:1.3 cells/test.lisp:1.4
--- cells/test.lisp:1.3 Sun May 8 14:42:12 2005
+++ cells/test.lisp Wed May 18 23:47:29 2005
@@ -20,6 +20,35 @@
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
+#| Synapse Cell Unification Notes
+
+- start by making Cells synapse-y
+
+- make sure outputs show right old and new values
+- make sure outputs fire when they should
+
+- wow: test the Cells II dictates: no output callback sees stale data, no rule
+sees stale data, etc etc
+
+- test a lot of different synapses
+
+- make sure they fire when they should, and do not when they should not
+
+- make sure they survive an evaluation by the user which does not branch to
+them (ie, does not access them)
+
+- make sure they optimize away
+
+- test with forms which access multiple other cells
+
+- look at direct alteration of a user
+
+- does SETF honor not propagating, as well as a c-ruled after re-calcing
+
+- do diff unchanged tests such as string-equal work
+
+|#
+
#| do list
-- can we lose the special handling of the .kids slot?
@@ -36,6 +65,7 @@
(defparameter *cell-tests* nil)
+
#+go
(test-cells)
@@ -69,88 +99,22 @@
(let ((m (make-be 'm-null :aa 42)))
(ct-assert (= 42 (aa m)))
(ct-assert (= 21 (decf (aa m) 21)))
- (ct-assert (= 21 (aa m)))
:okay-m-null))
-(defmodel m-ephem ()
- ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a)
- (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a)
- (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b)
- (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b)))
-
-(def-c-output m-ephem-a ()
- (setf (m-test-a self) new-value))
-
-(def-c-output m-ephem-b ()
- (setf (m-test-b self) new-value))
-
-(def-cell-test m-ephem
- (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0))))))
- (ct-assert (null (slot-value m 'm-ephem-a)))
- (ct-assert (null (m-ephem-a m)))
- (ct-assert (null (m-test-a m)))
- (ct-assert (null (slot-value m 'm-ephem-b)))
- (ct-assert (null (m-ephem-b m)))
- (ct-assert (zerop (m-test-b m)))
- (setf (m-ephem-a m) 3)
- (ct-assert (null (slot-value m 'm-ephem-a)))
- (ct-assert (null (m-ephem-a m)))
- (ct-assert (eql 3 (m-test-a m)))
- ;
- (ct-assert (null (slot-value m 'm-ephem-b)))
- (ct-assert (null (m-ephem-b m)))
- (ct-assert (eql 6 (m-test-b m)))
- ))
-
-(defmodel m-cyc ()
- ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a)
- (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b)))
-
-(def-c-output m-cyc-a ()
- (print `(output m-cyc-a ,self ,new-value ,old-value))
- (setf (m-cyc-b self) new-value))
-
-(def-c-output m-cyc-b ()
- (print `(output m-cyc-b ,self ,new-value ,old-value))
- (setf (m-cyc-a self) new-value))
-
-(defun m-cyc () ;;def-cell-test m-cyc
- (let ((m (make-be 'm-cyc)))
- (print `(start ,(m-cyc-a m)))
- (setf (m-cyc-a m) 42)
- (assert (= (m-cyc-a m) 42))
- (assert (= (m-cyc-b m) 42))))
-
-#+test
-(m-cyc)
-
-(defmodel m-cyc2 ()
- ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a)
- (m-cyc2-b :initform (c? (1+ (^m-cyc2-a)))
- :initarg :m-cyc2-b :accessor m-cyc2-b)))
-
-(def-c-output m-cyc2-a ()
- (print `(output m-cyc2-a ,self ,new-value ,old-value))
- #+not (when (< new-value 45)
- (setf (m-cyc2-b self) (1+ new-value))))
-
-(def-c-output m-cyc2-b ()
- (print `(output m-cyc2-b ,self ,new-value ,old-value))
- (when (< new-value 45)
- (setf (m-cyc2-a self) (1+ new-value))))
-
-(def-cell-test m-cyc2
- (cell-reset)
- (let ((m (make-be 'm-cyc2)))
- (print '(start))
- (setf (m-cyc2-a m) 42)
- (describe m)
- (assert (= (m-cyc2-a m) 44))
- (assert (= (m-cyc2-b m) 45))
- ))
-
-#+test
-(m-cyc2)
+(defmodel m-solo ()
+ ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a)
+ (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b)))
+
+(def-cell-test m-solo
+ (let ((m (make-be 'm-solo
+ :m-solo-a (c-in 42)
+ :m-solo-b (c? (* 2 (^m-solo-a))))))
+ (ct-assert (= 42 (m-solo-a m)))
+ (ct-assert (= 84 (m-solo-b m)))
+ (decf (m-solo-a m))
+ (ct-assert (= 41 (m-solo-a m)))
+ (ct-assert (= 82 (m-solo-b m)))
+ :okay-m-null))
(defmodel m-var ()
((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
