[cells-cvs] CVS update: cell-cultures/cells/cells.lisp cell-cultures/cells/family.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/md-utilities.lisp cell-cultures/cells/propagate.lisp
Kenny Tilton
ktilton at common-lisp.net
Wed Jul 7 01:25:41 UTC 2004
Update of /project/cells/cvsroot/cell-cultures/cells
In directory common-lisp.net:/tmp/cvs-serv4446/cells
Modified Files:
cells.lisp family.lisp integrity.lisp md-slot-value.lisp
md-utilities.lisp propagate.lisp
Log Message:
Date: Tue Jul 6 18:25:40 2004
Author: ktilton
Index: cell-cultures/cells/cells.lisp
diff -u cell-cultures/cells/cells.lisp:1.3 cell-cultures/cells/cells.lisp:1.4
--- cell-cultures/cells/cells.lisp:1.3 Sun Jul 4 11:59:41 2004
+++ cell-cultures/cells/cells.lisp Tue Jul 6 18:25:40 2004
@@ -38,15 +38,13 @@
(defparameter *c-debug* nil)
(defun cell-reset ()
- (setf *count* nil
- *stop* nil
- *dbg* nil
- *trcdepth* 0
- *c-prop-depth* 0
- *data-pulse-id* 0
- *data-pulses* nil
- *unfinished-business* nil
- )
+ (utils-kt-reset)
+ (setf
+ *c-debug* nil
+ *c-prop-depth* 0
+ *data-pulse-id* 0
+ *data-pulses* nil
+ *unfinished-business* nil)
(trc nil "------ cell reset ----------------------------"))
(defun c-stop (&optional why)
Index: cell-cultures/cells/family.lisp
diff -u cell-cultures/cells/family.lisp:1.1 cell-cultures/cells/family.lisp:1.2
--- cell-cultures/cells/family.lisp:1.1 Sat Jun 26 11:38:36 2004
+++ cell-cultures/cells/family.lisp Tue Jul 6 18:25:40 2004
@@ -182,6 +182,7 @@
(when (find-if 'zerop new-kids :key 'adopt-ct)
(dolist (k new-kids)
+ (trc nil "kids change sees new kid" self k)
(unless (member k old-kids)
(if (eql :nascent (md-state k))
(progn
Index: cell-cultures/cells/integrity.lisp
diff -u cell-cultures/cells/integrity.lisp:1.2 cell-cultures/cells/integrity.lisp:1.3
--- cell-cultures/cells/integrity.lisp:1.2 Sun Jul 4 11:59:41 2004
+++ cell-cultures/cells/integrity.lisp Tue Jul 6 18:25:40 2004
@@ -102,20 +102,25 @@
(count-it :ufb-wasted))
(finish-business)))))
+
+
(defun finish-business (&aux task some-output setfs (setf-ct 0))
(declare (ignorable setfs))
(tagbody
- start ;---------------------------------
- (setf task (cdr (fifo-pop (ufb-queue :user-notify))))
-
- (when task
- (trc nil "finish-business notifying--------------------------")
- (funcall task)
- (go start))
+ notify-users
+ ;--- notify users ------------------------------
+ (let ((user-q-item (fifo-pop (ufb-queue :user-notify))))
+ (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))
+ (funcall task)
+ (go notify-users))))
(setf some-output nil)
- next-output ;--------------------------
+ next-output
+ ;--- do c-output-slot-name -----------------------
(setf task (cdr (fifo-pop (ufb-queue :output))))
(cond
@@ -125,8 +130,9 @@
(funcall task)
(go next-output))
(some-output
- (go start)))
+ (go notify-users)))
+ ; --- do deferred setfs ------------------------
(setf task (fifo-pop (ufb-queue :setf)))
(when task
(incf setf-ct)
@@ -139,4 +145,4 @@
(push c setfs)
(data-pulse-next (list :finbiz c new-value))
(funcall task-fn))))
- (go start))))
+ (go notify-users))))
Index: cell-cultures/cells/md-slot-value.lisp
diff -u cell-cultures/cells/md-slot-value.lisp:1.2 cell-cultures/cells/md-slot-value.lisp:1.3
--- cell-cultures/cells/md-slot-value.lisp:1.2 Sun Jul 4 11:59:41 2004
+++ cell-cultures/cells/md-slot-value.lisp Tue Jul 6 18:25:40 2004
@@ -38,6 +38,7 @@
(defun c-value-ensure-current (c)
(count-it :c-value-ensure-current)
+ (trc nil "c-value-ensure-current>" c)
(cond
((c-inputp c))
((c-currentp c))
@@ -46,6 +47,7 @@
(c-calculate-and-set c))
(t (c-pulse-update c :valid-uninfluenced)))
+ ;;(unless (cmdead c)
(when (c-unboundp c)
(error 'unbound-cell :instance (c-model c) :name (c-slot-name c)))
@@ -64,34 +66,37 @@
(c-useds c))))
(defun c-calculate-and-set (c)
- (when (c-stopped)
- (princ #\.)
- (return-from c-calculate-and-set))
-
- (when (find c *c-calculators*) ;; circularity
- (trc "c-calculate-and-set breaking on circularity" c)
- (c-break ;; break is problem when testing cells on some CLs
- "cell ~a midst askers: ~a" c *c-calculators*))
-
- (count-it :c-calculate-and-set)
- ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
-
- (cd-usage-clear-all c)
-
- (let ((raw-value
- (progn
- (let ((*c-calculators* (cons c *c-calculators*)))
- (trc nil "c-calculate-and-set> just added to *c-calculators*:"
- *c-calculators*)
- (c-assert (c-model c))
- (funcall (cr-rule c) c)))))
+ (flet ((body ()
+ (when (c-stopped)
+ (princ #\.)
+ (return-from c-calculate-and-set))
- (when (and *c-debug* (typep raw-value 'cell))
- (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
- c raw-value))
+ (when (find c *c-calculators*) ;; circularity
+ (trc "c-calculate-and-set breaking on circularity" c)
+ (c-break ;; break is problem when testing cells on some CLs
+ "cell ~a midst askers: ~a" c *c-calculators*))
- (c-unlink-unused c)
- (md-slot-value-assume c raw-value)))
+ (count-it :c-calculate-and-set)
+ ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
+
+ (cd-usage-clear-all c)
+
+ (let ((raw-value
+ (progn
+ (let ((*c-calculators* (cons c *c-calculators*)))
+ (trc nil "c-calculate-and-set> just added to *c-calculators*:"
+ *c-calculators*)
+ (c-assert (c-model c))
+ (funcall (cr-rule c) c)))))
+ (progn ;; unless (cmdead c) ;; eg, rule includes (nsib), then parent decides (c-model c) is no more
+ (when (and *c-debug* (typep raw-value 'cell))
+ (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
+ c raw-value))
+
+ (c-unlink-unused c)
+ (md-slot-value-assume c raw-value)))))
+ (if nil ;; *dbg*
+ (ukt::wtrc (0 100 "calcnset" c) (body))(body))))
;-------------------------------------------------------------
Index: cell-cultures/cells/md-utilities.lisp
diff -u cell-cultures/cells/md-utilities.lisp:1.1 cell-cultures/cells/md-utilities.lisp:1.2
--- cell-cultures/cells/md-utilities.lisp:1.1 Sat Jun 26 11:38:36 2004
+++ cell-cultures/cells/md-utilities.lisp Tue Jul 6 18:25:40 2004
@@ -63,8 +63,9 @@
(trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self))
(defmethod not-to-be ((self model-object))
- (trc nil "not to be!!!" self)
- (unless (md-untouchable self)
+ (trc self "not to be!!!" self)
+ (if (md-untouchable self)
+ (trc "not-to-be not quiescing untouchable" self)
(md-quiesce self)))
(defmethod md-untouchable (self) ;; would be t for closed-stream under acl
@@ -72,7 +73,7 @@
nil)
(defun md-quiesce (self)
- (trc nil "md-quiesce doing" self)
+ (trc nil "md-quiesce doing" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *c-calculators*)))
Index: cell-cultures/cells/propagate.lisp
diff -u cell-cultures/cells/propagate.lisp:1.2 cell-cultures/cells/propagate.lisp:1.3
--- cell-cultures/cells/propagate.lisp:1.2 Sun Jul 4 11:59:41 2004
+++ cell-cultures/cells/propagate.lisp Tue Jul 6 18:25:40 2004
@@ -63,9 +63,14 @@
(let ((*causation* causation))
(trc nil "c-propagate-to-users > notifying users of" c)
(dolist (user (c-users c))
- (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c)
- (when (c-user-cares user)
- (c-value-ensure-current user)))))))
+ (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)
+ (c-value-ensure-current user))))
+ (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)))))))
(defun c-user-cares (c)
(not (or (c-currentp c)
@@ -139,13 +144,13 @@
(not (c-optimized-away-p c)) ;; the other way above condition can be met
(mdead (c-model c))))
-(defmethod cmdead :around (c)
+(defmethod cmdead :around (c )
(when (call-next-method)
(break "still reaching dead cells ~a" c)))
(defun mdead (m)
(when (eq :eternal-rest (md-state m))
- (break "still reaching dead instances ~a" m)))
+ (throw :mdead m)))
(defmacro def-c-output (slotname
(&optional (self-arg 'self) (new-varg 'new-value)
More information about the Cells-cvs
mailing list