[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Sat Oct 28 18:20:54 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv3409
Modified Files:
cell-types.lisp cells.lisp constructors.lisp link.lisp
md-slot-value.lisp md-utilities.lisp trc-eko.lisp
Log Message:
I forget. Some interesting stuff, I think.
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/17 21:28:39 1.20
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/28 18:20:48 1.21
@@ -38,9 +38,14 @@
(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
+ (optimize t)
debug
md-info)
+(defmethod trcp :around ((c cell))
+ (or (c-debug c)
+ (call-next-method)))
+
(defun c-callers (c)
"Make it easier to change implementation"
(fifo-data (c-caller-store c)))
@@ -96,7 +101,7 @@
rule)
(defun c-optimized-away-p (c)
- (eql :optimized-away (c-state c)))
+ (eq :optimized-away (c-state c)))
;----------------------------
--- /project/cells/cvsroot/cells/cells.lisp 2006/10/02 02:38:31 1.17
+++ /project/cells/cvsroot/cells/cells.lisp 2006/10/28 18:20:48 1.18
@@ -78,6 +78,8 @@
(defmacro without-c-dependency (&body body)
`(let (*call-stack*) , at body))
+(export! .cause)
+
(define-symbol-macro .cause
(car *causation*))
--- /project/cells/cvsroot/cells/constructors.lisp 2006/10/17 21:28:39 1.10
+++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/28 18:20:48 1.11
@@ -53,7 +53,15 @@
:value-state :unevaluated
:rule (c-lambda (without-c-dependency , at body))))
-(export! c?once)
+(defmacro c?n-until (&body body)
+ `(make-c-dependent
+ :optimize :when-value-t
+ :code ',body
+ :inputp t
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
+(export! c?once c?n-until)
(defmacro c?once (&body body)
`(make-c-dependent
:code '(without-c-dependency , at body)
--- /project/cells/cvsroot/cells/link.lisp 2006/10/17 21:28:39 1.19
+++ /project/cells/cvsroot/cells/link.lisp 2006/10/28 18:20:48 1.20
@@ -24,8 +24,10 @@
(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 used "record-caller entry: used=" used :caller caller)
+ (trc nil "record-caller entry: used=" used :caller caller)
+
(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 2006/10/17 21:28:39 1.29
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/28 18:20:48 1.30
@@ -65,7 +65,9 @@
;; 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)
- (c-validp c))) ;; a c?n (ruled-then-input) cell will not be valid at first
+ (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first
+ (not (and (eq (cd-optimize c) :when-value-t)
+ (null (c-value c))))))
((or (not (c-validp c))
;;
@@ -236,7 +238,11 @@
(c-value-state c) :valid
(c-state c) :awake)
- (c-optimize-away?! c) ;;; put optimize test here to avoid needless linking
+
+ (case (cd-optimize c)
+ ((t) (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
+ (:when-value-t (when (c-value c)
+ (c-unlink-from-used c))))
; --- data flow propagation -----------
(unless (eq propagation-code :no-propagate)
@@ -251,24 +257,29 @@
(defun c-optimize-away?! (c)
(when (and (typep c 'c-dependent)
+ (null (cd-useds c))
+ (cd-optimize c)
(not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
- (c-validp c)
+ (c-validp c) ;; /// when would this not be the case?
(not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
- ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))
- (not (c-inputp c))
- (null (cd-useds c)))
-
- (trc nil "optimizing away" c (c-state c))
+ (not (c-inputp c)) ;; yes, dependent cells can be inputp
+ )
+ (when (trcp c) (break "go optimizing ~a" c))
+ (trc c "optimizing away" c (c-state c))
(count-it :c-optimized)
(setf (c-state c) :optimized-away)
-
+
(let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
+ (unless entry
+ (describe c))
(c-assert entry)
+ (trc c "c-optimize-away?! moving cell to flushed list" c)
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
(push entry (cells-flushed (c-model c))))
-
+
(dolist (caller (c-callers c))
+ (break "got opti of called")
(setf (cd-useds caller) (delete c (cd-useds caller)))
(c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)))
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/17 21:28:39 1.9
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/28 18:20:48 1.10
@@ -33,13 +33,18 @@
;___________________ birth / death__________________________________
(defmethod not-to-be :around (self)
- (trc nil "not-to-be nailing" self)
+ (trc nil "not-to-be nailing")
(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))
(defmethod not-to-be ((self model-object))
@@ -47,7 +52,7 @@
(md-quiesce self))
(defun md-quiesce (self)
- (trc nil "md-quiesce doing" self (type-of self))
+ (trc nil "md-quiesce nailing cells" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
@@ -56,13 +61,13 @@
(defun c-quiesce (c)
(typecase c
(cell
- (trc c "c-quiesce unlinking" c)
+ (trc nil "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))))
+ (dolist (caller (c-callers c))
+ (setf (c-value-state caller) :uncurrent)
+ (c-unlink-caller c caller))
+ (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
+ )))
(defmethod not-to-be (other)
other)
--- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/17 21:28:39 1.4
+++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/28 18:20:48 1.5
@@ -85,9 +85,11 @@
(defmethod trcp :around (other)
(unless (call-next-method other)(break)))
+(export! trcp)
+
(defmethod trcp (other)
(eq other t))
-
+
(defmethod trcp (($ string))
t)
More information about the Cells-cvs
mailing list