[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Oct 17 21:28:39 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv6035
Modified Files:
cell-types.lisp cells.lpr constructors.lisp defpackage.lisp
integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp
model-object.lisp propagate.lisp trc-eko.lisp
Log Message:
Mostly someone screwing with file creation dates, but also a profound change to handling of cell currency in the face of model quiescence. See list (or code remarks re :uncurrent) for deets.
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 20:55:00 1.19
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/17 21:28:39 1.20
@@ -28,7 +28,13 @@
(caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
(state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
- (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
+ (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid}
+ ; uncurrent (aka dirty) new for 06-10-15. we need this so
+ ; c-quiesce can force a caller to update when asked
+ ; in case the owner of the quiesced cell goes out of existence
+ ; in a way the caller will not see via any kids dependency. Saw
+ ; this one coming a long time ago: depending on cell X implies
+ ; a dependency on the existence of instance owning X
(pulse 0 :type fixnum)
(pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP
lazy
--- /project/cells/cvsroot/cells/cells.lpr 2006/08/28 21:44:13 1.21
+++ /project/cells/cvsroot/cells/cells.lpr 2006/10/17 21:28:39 1.22
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cells/cvsroot/cells/constructors.lisp 2006/10/02 02:38:31 1.9
+++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/17 21:28:39 1.10
@@ -83,6 +83,17 @@
:lazy :until-asked
:rule (c-lambda , at body)))
+(export! c?dbg c_?dbg)
+
+(defmacro c_?dbg (&body body)
+ "Lazy until asked, then eagerly propagating"
+ `(make-c-dependent
+ :code ',body
+ :value-state :unevaluated
+ :lazy :until-asked
+ :rule (c-lambda , at body)
+ :debug t))
+
(defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body)
(let ((result (copy-symbol 'result))
(thetag (gensym)))
--- /project/cells/cvsroot/cells/defpackage.lisp 2006/06/20 14:16:44 1.7
+++ /project/cells/cvsroot/cells/defpackage.lisp 2006/10/17 21:28:39 1.8
@@ -42,6 +42,7 @@
#:class-precedence-list
#-(and mcl (not openmcl-partial-mop)) #:class-slots
#:slot-definition-name
+ #:class-direct-subclasses
)
(:export #:cell #:.md-name
#:c-input #:c-in #:c-in8
--- /project/cells/cvsroot/cells/integrity.lisp 2006/10/02 02:38:31 1.13
+++ /project/cells/cvsroot/cells/integrity.lisp 2006/10/17 21:28:39 1.14
@@ -70,6 +70,8 @@
(defun ufb-add (opcode continuation)
(assert (find opcode *ufb-opcodes*))
+ (when (and *no-tell* (eq opcode :tell-dependents))
+ (break "truly queueing tell under no-tell"))
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
(fifo-add (ufb-queue-ensure opcode) continuation))
@@ -81,7 +83,7 @@
while task
do (trc nil "unfin task is" opcode task)
(funcall task)))
-
+(defparameter *no-tell* nil)
(defun finish-business ()
(when *stop* (return-from finish-business))
(tagbody
@@ -99,7 +101,14 @@
; during their awakening to be handled along with those enqueued by cells of
; existing model instances.
;
- (just-do-it :awaken) ;--- md-awaken new instances ---
+ (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
+ (trcx finish-business uqp)
+ (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
+ (trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
+ (break "unexpected 1> ufb needs to tell dependnents after telling dependents"))
+ (let ((*no-tell* t))
+ (just-do-it :awaken) ;--- md-awaken new instances ---
+ )
;
; we do not go back to check for a need to :tell-dependents because (a) the original propagation
; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that
@@ -107,10 +116,12 @@
; awakening need that precisely because no one asked for their values, so there can be no dependents
; to "tell". I think. :) So...
;
- (when (fifo-peek (ufb-queue :tell-dependents))
+ (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
+ (trcx finish-business uqp)
(DOlist (b (fifo-data (ufb-queue :tell-dependents)))
(trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
- (break "ufb"))
+ (break "unexpected 2> ufb needs to tell dependnents after awakening"))
+
(assert (null (fifo-peek (ufb-queue :tell-dependents))))
;--- process client queue ------------------------------
--- /project/cells/cvsroot/cells/link.lisp 2006/10/02 20:55:00 1.18
+++ /project/cells/cvsroot/cells/link.lisp 2006/10/17 21:28:39 1.19
@@ -25,7 +25,7 @@
(defun record-caller (used &aux (caller (car *call-stack*)))
(when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
(return-from record-caller nil))
- (trc nil "record-caller entry: used=" used :caller caller)
+ (trc used "record-caller entry: used=" used :caller caller)
(multiple-value-bind (used-pos useds-len)
(loop with u-pos
for known in (cd-useds caller)
@@ -37,7 +37,7 @@
finally (return (values (when u-pos (- length u-pos)) length)))
(when (null used-pos)
- (trc nil "c-link > new caller,used " caller used)
+ (trc caller "c-link > new caller,used " caller used)
(count-it :new-used)
(setf used-pos useds-len)
(push used (cd-useds caller))
@@ -69,6 +69,7 @@
(zerop (sbit usage rpos)))
(progn
(count-it :unlink-unused)
+ (trc c "c-unlink-unused" c :dropping-used (car useds))
(c-unlink-caller (car useds) c)
(rplaca useds nil))
(progn
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/02 02:38:31 1.28
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/17 21:28:39 1.29
@@ -60,10 +60,12 @@
(break "model ~a of cell ~a is dead" (c-model c) c))
(cond
- ((c-currentp c)(trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
+ ((c-currentp c)
+ (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
;;
- ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above)
+ ((and (c-inputp c)
+ (c-validp c))) ;; a c?n (ruled-then-input) cell will not be valid at first
((or (not (c-validp c))
;;
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/09/03 13:41:09 1.8
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/17 21:28:39 1.9
@@ -56,10 +56,11 @@
(defun c-quiesce (c)
(typecase c
(cell
- (trc nil "c-quiesce unlinking" c)
+ (trc c "c-quiesce unlinking" c)
(c-unlink-from-used c)
(when (typep c 'cell)
(dolist (caller (c-callers c))
+ (setf (c-value-state caller) :uncurrent)
(c-unlink-caller c caller)))
(trc nil "cell quiesce nulled cell awake" c))))
@@ -70,6 +71,6 @@
(defmacro make-kid (class &rest initargs)
`(make-instance ,class
- :fm-parent (progn (assert self) self)
- , at initargs))
+ , at initargs
+ :fm-parent (progn (assert self) self)))
--- /project/cells/cvsroot/cells/model-object.lisp 2006/10/02 02:38:31 1.12
+++ /project/cells/cvsroot/cells/model-object.lisp 2006/10/17 21:28:39 1.13
@@ -178,7 +178,7 @@
(if entry
(progn
(setf (cdr entry) new-type)
- (loop for c in (mop:class-direct-subclasses (find-class class-name))
+ (loop for c in (class-direct-subclasses (find-class class-name))
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(push (cons slot-name new-type) (get class-name :cell-types)))))
@@ -194,7 +194,7 @@
(if entry
(progn
(setf (cdr entry) value)
- (loop for c in (mop:class-direct-subclasses (find-class class-name))
+ (loop for c in (class-direct-subclasses (find-class class-name))
do (setf (md-slot-owning (class-name c) slot-name) value)))
(push (cons slot-name value) (get class-name :ownings)))))
--- /project/cells/cvsroot/cells/propagate.lisp 2006/10/11 22:16:22 1.23
+++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/17 21:28:39 1.24
@@ -72,7 +72,7 @@
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc nil "c-propagate> propping" c (c-value c) :caller-ct (length (c-callers c)) c)
+ (trc c "c-propagate> !!!!!!!!!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
@@ -168,9 +168,12 @@
; but B is busy eagerly propagating. "This time" is important because it means
; there is no way one can reliably be sure H will not ask for A
;
- (when (c-callers c)
- (trc nil "c-propagate-to-callers > queueing" c)
- (let ((causation (cons c *causation*))) ;; in case deferred
+ (when (find-if-not (lambda (caller)
+ (and (c-lazy caller) ;; slight optimization
+ (member (c-lazy caller) '(t :always :once-asked))))
+ (c-callers c))
+ (let ((causation (cons c *causation*)) ;; in case deferred
+ )
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
--- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/06 08:01:10 1.3
+++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/17 21:28:39 1.4
@@ -126,6 +126,14 @@
(trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
,result)))
+(defmacro ekx (ekx-id &rest body)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result)
+ ,result)))
+
+(export! ekx)
+
(defmacro eko-if ((&rest trcargs) &rest body)
(let ((result (gensym)))
`(let ((,result , at body))
More information about the Cells-cvs
mailing list