Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3487

Modified Files: cell-types.lisp cells.lisp cells.lpr constructors.lisp family.lisp fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp slot-utilities.lisp trc-eko.lisp variables.lisp Log Message: Some interesting changes

--- /project/cells/cvsroot/cells/cell-types.lisp 2006/12/12 15:58:42 1.24 +++ /project/cells/cvsroot/cells/cell-types.lisp 2007/01/29 06:43:48 1.25 @@ -87,9 +87,7 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller))

-;;;(defmethod trcp ((c cell)) -;;; (and (typep (c-model c) 'index) -;;; (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) +

; --- ephemerality -------------------------------------------------- ; --- /project/cells/cvsroot/cells/cells.lisp 2006/12/12 15:58:42 1.19 +++ /project/cells/cvsroot/cells/cells.lisp 2007/01/29 06:43:52 1.20 @@ -17,7 +17,7 @@ |#

(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))

(in-package :cells)

@@ -79,7 +79,7 @@ `(call-without-c-dependency (lambda () ,@body)))

(defun call-without-c-dependency (fn) - (let (*call-stack*); *no-tell*) + (let (*call-stack*) (funcall fn)))

(export! .cause) --- /project/cells/cvsroot/cells/cells.lpr 2006/12/13 18:05:08 1.26 +++ /project/cells/cvsroot/cells/cells.lpr 2007/01/29 06:43:59 1.27 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-

(in-package :cg-user)

--- /project/cells/cvsroot/cells/constructors.lisp 2006/12/13 18:05:08 1.15 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/01/29 06:43:59 1.16 @@ -26,10 +26,13 @@ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) ,@body))

+(export! .cache-bound-p) + (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) - (.cache (c-value ,c))) - (declare (ignorable .cache self)) + (.cache (c-value ,c)) + (.cache-bound-p (cache-bound-p ,c))) + (declare (ignorable .cache .cache-bound-p self)) ,@body))

(defmacro with-c-cache ((fn) &body body) --- /project/cells/cvsroot/cells/family.lisp 2006/12/13 18:05:08 1.18 +++ /project/cells/cvsroot/cells/family.lisp 2007/01/29 06:43:59 1.19 @@ -39,7 +39,8 @@

(defmethod print-object ((self model) s) #+shhh (format s "~a" (type-of self)) - (format s "~a" (or (md-name self) (type-of self)))) + (format s "~a~a" (if (mdead self) "DEAD!" "") + (or (md-name self) (type-of self))))

(define-symbol-macro .parent (fm-parent self))

--- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/04 20:52:01 1.14 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2007/01/29 06:43:59 1.15 @@ -44,7 +44,7 @@ (defmacro upper (self &optional (type t)) `(container-typed ,self ',type))

-(export! u^) +(export! u^ fm-descendant-if)

(defmacro u^ (type) `(upper self ,type)) @@ -93,6 +93,13 @@ self) (fm-ascendant-if .parent if-function))))

+(defun fm-descendant-if (self test) + (when (and self test) + (or (when (funcall test self) + self) + (loop for k in (^kids) + thereis (fm-descendant-if k test))))) + (defun fm-ascendant-common (d1 d2) (fm-ascendant-some d1 (lambda (node) (when (fm-includes node d2) @@ -440,11 +447,11 @@ :must-find t :global-search global-search))

-(defmacro fm^ (md-name &key (skip-tree 'self)) +(defmacro fm^ (md-name &key (skip-tree 'self) (must-find t)) `(without-c-dependency (fm-find-one (fm-parent self) ,md-name :skip-tree ,skip-tree - :must-find t + :must-find ,must-find :global-search t)))

(defmacro fm^v (id) @@ -494,7 +501,7 @@ :must-find nil :global-search ,global-search))) ;--------------------------------------------------------------- - +(export! fm-top) (defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm))) (cond ((null fm-parent) fm) ((not (funcall test fm-parent)) fm) --- /project/cells/cvsroot/cells/integrity.lisp 2006/11/13 05:28:08 1.16 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/01/29 06:44:00 1.17 @@ -84,7 +84,7 @@ (defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q) (ufb-queue op-or-q) op-or-q))) - (trc nil "just do it doing" op-or-q) + (trc nil "----------------------------just do it doing---------------------" op-or-q) (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) @@ -165,7 +165,7 @@ (bwhen (task-info (fifo-pop (ufb-queue :change))) (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info - (trc nil "finbiz: deferred state change" defer-info) + (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) (funcall task-fn :change defer-info) ; @@ -178,3 +178,4 @@ ; (go tell-dependents)))))

+ --- /project/cells/cvsroot/cells/link.lisp 2006/12/12 15:58:42 1.22 +++ /project/cells/cvsroot/cells/link.lisp 2007/01/29 06:44:01 1.23 @@ -18,21 +18,11 @@

(in-package :cells)

-#+(or) -(eval-when (compile load) - (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) - - (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 (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) -;;; (when (trcp caller) -;;; -;;; ;;(when (eq (c-slot-name caller) 'mathx::phrases) -;;; (when (eq (c-slot-name used) 'mathx::opnds) -;;; (break "bingo")))

(multiple-value-bind (used-pos useds-len) (loop with u-pos @@ -121,7 +111,7 @@ ;----------------------------------------------------------

(defun c-unlink-caller (used caller) - (trc caller "(1) caller unlinking from (2) used" caller used) + (trc nil "(1) caller unlinking from (2) used" caller used) (caller-drop used caller) (c-unlink-used caller used))

--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/12/12 15:58:42 1.33 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/01/29 06:44:01 1.34 @@ -21,6 +21,9 @@ (defparameter *ide-app-hard-to-kill* t)

(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) + (return-from md-slot-value nil)) (tagbody retry (when *stop* @@ -55,6 +58,12 @@ (when (eq :eternal-rest (md-state s)) (break "model ~a is dead at ~a" s key)))

+;;;(defmethod trcp ((c cell)) +;;; (and *dbg* +;;; (case (c-slot-name c) +;;; (mathx::show-time t) +;;; (ctk::app-time t)))) + (defun ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure @@ -69,7 +78,7 @@

(cond ((c-currentp c) - (trc c "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete + (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 ;; ((and (c-inputp c) @@ -106,7 +115,12 @@ (when (c-unboundp c) (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))

- (c-value c)) + (bwhen (v (c-value c)) + (if (mdead v) + (progn + (trc "ensure-value not returning dead model object value" v) + nil) + v)))

(defun calculate-and-set (c) (flet ((body () @@ -260,11 +274,17 @@ (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) (setf (c-pulse-last-changed c) *data-pulse-id*) - (c-propagate c prior-value (or (eq prior-state :valid) - (eq prior-state :uncurrent)))) ;; until 06-02-13 was (not (eq prior-state :unbound)) + (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound))

absorbed-value)))

+(defun cache-bound-p (c) + (cache-state-bound-p (c-value-state c))) + +(defun cache-state-bound-p (value-state) + (or (eq value-state :valid) + (eq value-state :uncurrent))) + ;---------- optimizing away cells whose dependents all turn out to be constant ---------------- ;

--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/11/03 13:37:10 1.11 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2007/01/29 06:44:01 1.12 @@ -27,29 +27,39 @@ (defmethod md-release (other) (declare (ignorable other)))

-(export! md-dead) -(defun md-dead (SELF) - (eq :eternal-rest (md-state SELF))) +(export! mdead) ;___________________ birth / death__________________________________

-(defmethod not-to-be :around (self) - (trc nil "not-to-be nailing") - (c-assert (not (eq (md-state self) :eternal-rest))) +(defgeneric mdead (self)

- (call-next-method) + (:method ((self model-object)) + (eq :eternal-rest (md-state SELF)))

- (setf (fm-parent self) nil - (md-state self) :eternal-rest) + (:method (self) + (declare (ignore self)) + nil))

- (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) +(defgeneric not-to-be (self)

- (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) + (:method ((self model-object)) + (md-quiesce self))

-(defmethod not-to-be ((self model-object)) - (trc nil "not to be!!!" self) - (md-quiesce self)) + (:method :around ((self model-object)) + (declare (ignorable self)) + (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) + "not-to-be nailing" self) + (c-assert (not (eq (md-state self) :eternal-rest))) + + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) + + (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)))

(defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) @@ -70,8 +80,7 @@ (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho )))

-(defmethod not-to-be (other) - other) +

(defparameter *to-be-dbg* nil)

--- /project/cells/cvsroot/cells/model-object.lisp 2006/11/13 05:28:08 1.14 +++ /project/cells/cvsroot/cells/model-object.lisp 2007/01/29 06:44:01 1.15 @@ -116,7 +116,7 @@ (trc nil "md-awaken entry" self (md-state self)) (c-assert (eql :nascent (md-state self))) (count-it :md-awaken) - (count-it 'mdawaken) + ;(count-it 'mdawaken (type-of self))

; ---

--- /project/cells/cvsroot/cells/propagate.lisp 2006/11/13 05:28:08 1.26 +++ /project/cells/cvsroot/cells/propagate.lisp 2007/01/29 06:44:01 1.27 @@ -46,7 +46,7 @@

(defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating" *data-pulse-id* c key :prior-pulse (c-pulse c)) + (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)) (assert (>= *data-pulse-id* (c-pulse c)) () "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c) (setf (c-pulse c) *data-pulse-id*)) @@ -59,7 +59,7 @@ ;

(defun c-propagate (c prior-value prior-value-supplied) - + (count-it :c-propagate) (when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) @@ -67,13 +67,13 @@ (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) (trc nil "c-propagate clearing *call-stack*" c) - + ;------ debug stuff --------- ; (when *stop* (princ #.)(princ #!) (return-from c-propagate)) - (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) @@ -97,10 +97,10 @@ (flet ((listify (x) (if (listp x) x (list x)))) (bIf (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn - (trc nil "prop nailing owned" c :lost lost :leaving (c-value c)) + (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c)) (mapcar 'not-to-be lost)) (trc nil "no owned lost!!!!!")))) - + ; propagation to callers jumps back in front of client slot-value-observe handling in cells3 ; because model adopting (once done by the kids change handler) can now be done in ; shared-initialize (since one is now forced to supply the parent to make-instance). @@ -111,10 +111,10 @@ ; (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied) - +

; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so @@ -185,21 +185,26 @@ (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 - ) - (TRC c "c-propagate-to-callers > queueing notifying callers" (mapcar 'c-slot-name (c-callers c))) + (let ((causation (cons c *causation*))) ;; in case deferred + (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc c "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) - (dolist (caller (c-callers c)) - (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) - - (dolist (caller (c-callers c)) ;; following code may modify c-callers list... + (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c)) + #+c-debug (dolist (caller (c-callers c)) + (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) + (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) + (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced + (member (c-lazy caller) '(t :always :once-asked))) + (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c) + )) + (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller)) (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced (member (c-lazy caller) '(t :always :once-asked))) - (assert (find c (cd-useds caller))) - (trc caller "propagating to caller is caller:" caller) + (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) + (trc nil "propagating to caller is used" c :caller caller) (ensure-value-is-current caller :prop-from c))))))))

--- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/11/13 05:28:08 1.4 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2007/01/29 06:44:01 1.5 @@ -36,7 +36,7 @@ ;; cv-test handles errors, so don't set *stop* (c-stop) (c-break "unadopted ~a for self ~a spec ~a" c self slot-name) (error 'c-unadopted :cell c)) - (typecase c + #+whocares (typecase c (c-dependent ;(trc "setting c-dependent" c newvalue) (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/28 18:20:48 1.5 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2007/01/29 06:44:01 1.6 @@ -52,9 +52,9 @@ (if (eql tgt-form 'nil) '(progn) `(without-c-dependency - (call-trc t ,(format nil "TX> ~(~a~)" tgt-form) + (call-trc t ,(format nil "TX> ~(~s~)" tgt-form) ,@(loop for obj in os - nconcing (list (format nil "~a:" obj) obj)))))) + nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))

(defparameter *last-trc* (get-internal-real-time)) --- /project/cells/cvsroot/cells/variables.lisp 2006/12/13 18:05:08 1.1 +++ /project/cells/cvsroot/cells/variables.lisp 2007/01/29 06:44:01 1.2 @@ -60,6 +60,7 @@ #+test (def-c-variable *kenny* (c-in nil))

+ #+test (defmd kenny-watcher () (twice (c? (bwhen (k *kenny*)