[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Mon Jan 29 06:44:03 UTC 2007
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 () , at 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) , at 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))
, at 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*)
More information about the Cells-cvs
mailing list