[cells-cvs] CVS update: cells/cells.lisp cells/constructors.lisp cells/defpackage.lisp cells/integrity.lisp cells/md-slot-value.lisp cells/optimization.lisp cells/propagate.lisp cells/test.lisp
Kenny Tilton
ktilton at common-lisp.net
Sun May 8 12:42:15 UTC 2005
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*) , at 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 , at 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 , at 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)
, at 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)
More information about the Cells-cvs
mailing list