Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv15583
Modified Files: cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp optimization.lisp propagate.lisp test.lisp Log Message: Test for *stop*ped Cells. Eliminate *causation*, auto-detection of causal looping. Date: Sun May 8 14:42:13 2005 Author: ktilton
Index: cells/cells.lisp diff -u cells/cells.lisp:1.1 cells/cells.lisp:1.2 --- cells/cells.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/cells.lisp Sun May 8 14:42:12 2005 @@ -30,7 +30,6 @@
(define-constant *c-optimizep* t) (defparameter *c-prop-depth* 0) -(defparameter *causation* nil)
(defparameter *data-pulse-id* 0) (defparameter *data-pulses* nil) @@ -88,9 +87,6 @@
(defmacro without-c-dependency (&body body) `(let (*c-calculators*) ,@body)) - -(define-symbol-macro .cause - (car *causation*))
(define-condition unbound-cell (unbound-slot) ())
Index: cells/constructors.lisp diff -u cells/constructors.lisp:1.1 cells/constructors.lisp:1.2 --- cells/constructors.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/constructors.lisp Sun May 8 14:42:12 2005 @@ -62,7 +62,7 @@ :lazy t :rule (c-lambda ,@body)))
-(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body) +(defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) (let ((result (copy-symbol 'result)) (thetag (gensym))) `(make-c-dependent @@ -75,7 +75,6 @@ (declare (ignorable self ,thetag)) ,(when in `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) - ,(when trigger `(trc "c??> trigger" .cause c)) (count-it :c?? (c-slot-name c) (md-name (c-model c))) (let ((,result (progn ,@body))) ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
Index: cells/defpackage.lisp diff -u cells/defpackage.lisp:1.1 cells/defpackage.lisp:1.2 --- cells/defpackage.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/defpackage.lisp Sun May 8 14:42:12 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 #:.cause + #:.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/integrity.lisp diff -u cells/integrity.lisp:1.1 cells/integrity.lisp:1.2 --- cells/integrity.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/integrity.lisp Sun May 8 14:42:12 2005 @@ -106,7 +106,7 @@
-(defun finish-business (&aux task some-output setfs (setf-ct 0)) +(defun finish-business (&aux task some-output setfs) (declare (ignorable setfs)) (assert (ufb-queue :user-notify)) (assert (consp (ufb-queue :user-notify))) @@ -141,16 +141,11 @@ ; --- do deferred setfs ------------------------ (setf task (fifo-pop (ufb-queue :setf))) (when task - (incf setf-ct) (destructuring-bind ((c new-value) . task-fn) task (trc nil "finbiz: deferred setf" c new-value) - (if (find c *causation*) - (break "setf looping setting ~a to ~a with history ~a" - c new-value *causation*) - (progn - (push c setfs) - (data-pulse-next (list :finbiz c new-value)) - (funcall task-fn)))) + (push c setfs) + (data-pulse-next (list :finbiz c new-value)) + (funcall task-fn)) (go notify-users))
; --- do finalizations ------------------------
Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.2 cells/md-slot-value.lisp:1.3 --- cells/md-slot-value.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/md-slot-value.lisp Sun May 8 14:42:12 2005 @@ -22,19 +22,34 @@
(in-package :cells)
+(defparameter *ide-app-hard-to-kill* nil)
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) - (when *stop* - (princ #.) - (return-from md-slot-value)) - ;; (count-it :md-slot-value slot-name) - (if c - (prog1 - (with-integrity (:md-slot-value) - (c-value-ensure-current c)) - (when (car *c-calculators*) - (c-link-ex c))) - (values (bd-slot-value self slot-name) nil))) + (tagbody + retry + (when *stop* + (if *ide-app-hard-to-kill* + (progn + (princ #.) + (return-from md-slot-value)) + (restart-case + (error "Cells is stopped due to a prior error.") + (continue () + :report "Return a slot value of nil." + (return-from md-slot-value nil)) + (reset-cells () + :report "Reset cells and retry getting the slot value." + (cell-reset) + (go retry))))) + + ;; (count-it :md-slot-value slot-name) + (if c + (prog1 + (with-integrity (:md-slot-value) + (c-value-ensure-current c)) + (when (car *c-calculators*) + (c-link-ex c))) + (values (bd-slot-value self slot-name) nil))))
(defun c-value-ensure-current (c) (count-it :c-value-ensure-current) @@ -123,10 +138,8 @@ (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) nil prior-value :makunbound))
- (let ((causation *causation*)) - (with-integrity (:makunbound :makunbound c) - (let ((*causation* causation)) - (c-propagate c prior-value t))))))) + (with-integrity (:makunbound :makunbound c) + (c-propagate c prior-value t)))))
(defun (setf md-slot-value) (new-value self slot-name @@ -137,26 +150,13 @@ (when *c-debug* (c-setting-debug self slot-name c new-value))
- (if c - (when (find c *causation*) - (case (c-cyclicp c) - (:run-on (trc "cyclicity running on" c)) - ((t) - (progn - (trc "cyclicity handled gracefully" c) - (c-pulse-update c :cyclicity-1) - (return-from md-slot-value new-value))) - (otherwise - (c-break "(setf md-slot-value) setf looping ~a ~a" c *causation*)))) - (progn - (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" - slot-name self))) + (unless c + (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" + slot-name self))
- (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)))) + (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))
new-value)
@@ -164,13 +164,6 @@
(defmethod md-slot-value-assume (c raw-value) (assert c) - (bif (c-pos (position c *causation*)) - (bif (cyclic-pos (position-if 'c-cyclicp *causation* :end c-pos)) - (progn - (c-pulse-update c :cyclicity-0) - (return-from md-slot-value-assume raw-value)) - (c-break "md-slot-value-assume looping ~a ~a" c *causation*))) - (without-c-dependency (let ((prior-state (c-value-state c)) (prior-value (c-value c))
Index: cells/optimization.lisp diff -u cells/optimization.lisp:1.2 cells/optimization.lisp:1.3 --- cells/optimization.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/optimization.lisp Sun May 8 14:42:12 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 (syn) (null (cd-useds syn))) (cd-synapses c)) + (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c)) (null (cd-useds c)))
(progn
Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.2 cells/propagate.lisp:1.3 --- cells/propagate.lisp:1.2 Sun May 8 01:12:40 2005 +++ cells/propagate.lisp Sun May 8 14:42:12 2005 @@ -57,11 +57,10 @@ (c-value c) prior-value prior-value-supplied)))
(defun c-propagate-to-users (c) - (trc nil "c-propagate-to-users > queueing" c :cause *causation*) - (let ((causation (cons c *causation*))) ;; in case deferred - (with-integrity (:user-notify :user-notify c) + (trc nil "c-propagate-to-users > queueing" c) + (with-integrity (:user-notify :user-notify c) (assert (null *c-calculators*)) - (let ((*causation* causation)) + (progn (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) (bwhen (dead (catch :mdead @@ -72,7 +71,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) @@ -82,18 +81,15 @@ (getf (symbol-plist slot-name) :output-defined))
(defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation *causation*)) ;; in case deferred - (with-integrity (:c-output-slot :output c) - (let ((*causation* causation)) - (trc nil "c-output-slot > causation" c *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))))) + (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)))
(defun c-ephemeral-reset (c) (when c
Index: cells/test.lisp diff -u cells/test.lisp:1.2 cells/test.lisp:1.3 --- cells/test.lisp:1.2 Sun May 8 01:12:41 2005 +++ cells/test.lisp Sun May 8 14:42:12 2005 @@ -54,6 +54,7 @@ `(progn (pushnew ',name *cell-tests*) (defun ,name () + (cell-reset) ,@body)))
(defmacro ct-assert (form &rest stuff) @@ -100,6 +101,56 @@ (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-var () ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)