[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Jan 29 04:29:54 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv21938
Modified Files:
cell-types.lisp cells.lisp fm-utilities.lisp link.lisp
md-slot-value.lisp md-utilities.lisp model-object.lisp
synapse-types.lisp trc-eko.lisp
Log Message:
--- /project/cells/cvsroot/cells/cell-types.lisp 2007/12/03 20:11:11 1.27
+++ /project/cells/cvsroot/cells/cell-types.lisp 2008/01/29 04:29:52 1.28
@@ -66,8 +66,9 @@
(call-next-method)
(progn
(c-print-value c stream)
- (format stream "=~d/~a/~a]"
+ (format stream "=~d/~a/~a/~a]"
(c-pulse c)
+ (c-state c)
(symbol-name (or (c-slot-name c) :anoncell))
(print-cell-model (c-model c))))))))
@@ -92,8 +93,6 @@
(defun caller-drop (used caller)
(fifo-delete (c-caller-store used) caller))
-
-
; --- ephemerality --------------------------------------------------
;
; Not a type, but an option to the :cell parameter of defmodel
--- /project/cells/cvsroot/cells/cells.lisp 2007/11/30 22:29:06 1.22
+++ /project/cells/cvsroot/cells/cells.lisp 2008/01/29 04:29:52 1.23
@@ -54,6 +54,7 @@
(defun c-stop (&optional why)
(setf *stop* t)
+ (print `(c-stop-entry ,why))
(format t "~&C-STOP> stopping because ~a" why) )
(define-symbol-macro .stop
@@ -151,13 +152,11 @@
(defun c-break (&rest args)
(unless *stop*
- (let ((*print-level* 3)
+ (let ((*print-level* 5)
(*print-circle* t)
- )
+ (args2 (mapcar 'princ-to-string args)))
(c-stop args)
- (format t "c-break > stopping > ~a" args)
- (apply 'error args))))
-
-
-
-
+
+ (format t "~&c-break > stopping > ~{~a ~}" args2)
+ (print `(c-break-args , at args2))
+ (apply 'error args2))))
\ No newline at end of file
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2007/11/30 16:51:18 1.16
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/01/29 04:29:52 1.17
@@ -33,7 +33,8 @@
(apply #'make-instance part-class (append initargs (list :md-name partname)))))
(defmacro mk-part (md-name (md-class) &rest initargs)
- `(make-part ',md-name ',md-class , at initargs))
+ `(make-part ',md-name ',md-class , at initargs
+ :fm-parent (progn (assert self) self)))
(defmethod make-part-spec ((part-class symbol))
(make-part part-class part-class))
--- /project/cells/cvsroot/cells/link.lisp 2007/11/30 16:51:18 1.24
+++ /project/cells/cvsroot/cells/link.lisp 2008/01/29 04:29:52 1.25
@@ -23,7 +23,9 @@
(trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used)
(return-from record-caller nil))
(trc nil "record-caller entry: used=" used :caller caller)
-
+ #+cool (when (and (eq :ccheck (md-name (c-model caller)))
+ (eq :cview (md-name (c-model used))))
+ (break "bingo"))
(multiple-value-bind (used-pos useds-len)
(loop with u-pos
for known in (cd-useds caller)
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 22:29:06 1.36
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/29 04:29:52 1.37
@@ -23,6 +23,8 @@
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
(when (mdead self)
(trc "md-slot-value passed dead self, returning NIL" self)
+ (inspect self)
+ (break "see inspector for dead ~a" self)
(return-from md-slot-value nil))
(tagbody
retry
@@ -73,7 +75,7 @@
;
(declare (ignorable debug-id ensurer))
(count-it :ensure-value-is-current)
- (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id ensurer)
+ ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer)
(when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c))))
(break "model ~a of cell ~a is dead" (c-model c) c))
@@ -110,14 +112,15 @@
t))))))
(assert (typep c 'c-dependent))
(check-reversed (cd-useds c))))
- #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c)
+ #+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c)
:stamped (c-pulse c) :current-pulse *data-pulse-id*)
(calculate-and-set c))
((mdead (c-value c))
- (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
+ (trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
(let ((new-v (calculate-and-set c)))
- (trc "ensure-value-is-current> GOT new value ~a" new-v)))
+ (trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v)
+ new-v))
(t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
(c-pulse-update c :valid-uninfluenced)))
@@ -128,7 +131,7 @@
(bwhen (v (c-value c))
(if (mdead v)
(progn
- (brk "ensure-value still got and still not returning ~a dead value ~a" c v)
+ (brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
nil)
v)))
@@ -162,8 +165,14 @@
(c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
c raw-value))
- (md-slot-value-assume c raw-value propagation-code))))
- (if nil ;; *dbg*
+ (unless (c-optimized-away-p c)
+ ; this check for optimized-away-p arose because a rule using without-c-dependency
+ ; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent
+ ; re-exit will be of an optimized away cell, which we need not sv-assume on... a better
+ ; fix might be a less cutesy way of doing without-c-dependency, and I think anyway
+ ; it would be good to lose the re-entrance.
+ (md-slot-value-assume c raw-value propagation-code)))))
+ (if (trcp c) ;; *dbg*
(wtrc (0 100 "calcnset" c) (body))
(body))))
@@ -171,7 +180,7 @@
(let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
(assert (typep c 'c-ruled))
- #+slow (trc *c-debug* "calculate-and-link" c)
+ #+shhh (trc c "calculate-and-link" c)
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
@@ -236,6 +245,7 @@
(md-slot-value-assume c new-value nil))
(*defer-changes*
+ (print `(cweird ,c ,(type-of c)))
(c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
(t
@@ -250,6 +260,7 @@
(defmethod md-slot-value-assume (c raw-value propagation-code)
(assert c)
+ #+shhh (trc c "md-slot-value-assume entry" (c-state c))
(without-c-dependency
(let ((prior-state (c-value-state c))
(prior-value (c-value c))
@@ -266,9 +277,12 @@
(return-from md-slot-value-assume absorbed-value))
; --- slot maintenance ---
+ (when (eq (c-state c) :optimized-away)
+ (break "bongo one ~a flush ~a" c (flushed? c)))
(unless (c-synaptic c)
(md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
-
+ (when (eq (c-state c) :optimized-away)
+ (break "bongo two ~a flush ~a" c (flushed? c)))
; --- cell maintenance ---
(setf
(c-value c) absorbed-value
@@ -299,7 +313,11 @@
;---------- optimizing away cells whose dependents all turn out to be constant ----------------
;
+(defun flushed? (c)
+ (rassoc c (cells-flushed (c-model c))))
+
(defun c-optimize-away?! (c)
+ #+shhh (trc c "c-optimize-away?! entry" (c-state c) c)
(when (and (typep c 'c-dependent)
(null (cd-useds c))
(cd-optimize c)
@@ -309,21 +327,27 @@
(not (c-inputp c)) ;; yes, dependent cells can be inputp
)
;; (when (trcp c) (break "go optimizing ~a" c))
- (trc nil "optimizing away" c (c-state c))
+
+ #+shh (when (trcp c)
+ (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
+ )
+
(count-it :c-optimized)
(setf (c-state c) :optimized-away)
(let ((entry (rassoc c (cells (c-model c)))))
(unless entry
- (describe c))
+ (describe c)
+ (bwhen (fe (rassoc c (cells-flushed (c-model c))))
+ (trc "got in flushed thoi!" fe)))
(c-assert entry)
- (trc nil "c-optimize-away?! moving cell to flushed list" c)
+ ;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c)
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
#-its-alive! (push entry (cells-flushed (c-model c)))
)
- (dolist (caller (c-callers c))
+ (dolist (caller (c-callers c) )
;
; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
; kicked off and asked about the value of a dead instance. That returns nil, and
@@ -332,6 +356,7 @@
; so we ended up here. where there used to be a break.
;
(setf (cd-useds caller) (delete c (cd-useds caller)))
+ ;;; (trc "nested opti" c caller)
(c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)))
--- /project/cells/cvsroot/cells/md-utilities.lisp 2007/11/30 16:51:18 1.13
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/01/29 04:29:52 1.14
@@ -40,7 +40,6 @@
nil))
(defgeneric not-to-be (self)
-
(:method ((self model-object))
(md-quiesce self))
--- /project/cells/cvsroot/cells/model-object.lisp 2007/11/30 16:51:18 1.16
+++ /project/cells/cvsroot/cells/model-object.lisp 2008/01/29 04:29:52 1.17
@@ -106,6 +106,9 @@
(when (eql :nascent (md-state self))
(call-next-method)))
+#+test
+(md-slot-cell-type 'cgtk::label 'cgtk::container)
+
(defmethod md-awaken ((self model-object))
;
; --- debug stuff
@@ -123,7 +126,7 @@
(setf (md-state self) :awakening)
(dolist (esd (class-slots (class-of self)))
- (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
+ (bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
(let* ((slot-name (slot-definition-name esd))
(c (md-slot-cell self slot-name)))
(when *c-debug*
@@ -146,6 +149,7 @@
;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
;; but first I worried about it being slow keeping the flushed list /and/ searching, then
;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
+
(slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
@@ -175,6 +179,9 @@
(cdr (assoc slot-name (cells self)))
(get slot-name 'cell)))
+#+test
+(get 'cgtk::label :cell-types)
+
(defun md-slot-cell-type (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
@@ -192,11 +199,11 @@
(setf (get slot-name :cell-type) new-type)
(let ((entry (assoc slot-name (get class-name :cell-types))))
(if entry
- (progn
+ (prog1
(setf (cdr entry) new-type)
(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))))))
+ (cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
(defun md-slot-owning (class-name slot-name)
(assert class-name)
--- /project/cells/cvsroot/cells/synapse-types.lisp 2007/11/30 16:51:18 1.6
+++ /project/cells/cvsroot/cells/synapse-types.lisp 2008/01/29 04:29:52 1.7
@@ -36,7 +36,7 @@
(defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
(with-synapse synapse-id (prior-fire-value)
(let ((new-value (funcall body-fn)))
- (trc nil "f-sensitivity fire-p decides" prior-fire-value sensitivity)
+ ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity)
(let ((prop-code (if (or (xor prior-fire-value new-value)
(eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity)
(delta-greater-or-equal
--- /project/cells/cvsroot/cells/trc-eko.lisp 2007/11/30 16:51:18 1.7
+++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 04:29:52 1.8
@@ -33,7 +33,7 @@
`(without-c-dependency
(call-trc t ,tgt-form , at os))
(let ((tgt (gensym)))
- ;(break "slowww? ~a" tgt-form)
+ (break "slowww? ~a" tgt-form)
`(without-c-dependency
(bif (,tgt ,tgt-form)
(if (trcp ,tgt)
@@ -64,7 +64,7 @@
'(progn)
`(without-c-dependency
(call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
- ,@(loop for obj in os
+ ,@(loop for obj in (or os (list tgt-form))
nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
More information about the Cells-cvs
mailing list