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 ,@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 ,@initargs)) + `(make-part ',md-name ',md-class ,@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 ,@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))))))