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)