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)