[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Dec 12 15:58:42 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv9859
Modified Files:
cell-types.lisp cells.lisp cells.lpr constructors.lisp
defmodel.lisp link.lisp md-slot-value.lisp
Log Message:
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/11/13 05:28:08 1.23
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/12/12 15:58:42 1.24
@@ -42,6 +42,8 @@
debug
md-info)
+
+
;_____________________ print __________________________________
#+sigh
@@ -67,7 +69,7 @@
(format stream "=~d/~a/~a]"
(c-pulse c)
(symbol-name (or (c-slot-name c) :anoncell))
- (bwhen (md (c-model c)) (md-name md) :anonmd)))))))
+ (bwhen (md (c-model c)) (or (md-name md) :anonmd))))))))
(defmethod trcp :around ((c cell))
(or (c-debug c)
@@ -79,6 +81,7 @@
(defun caller-ensure (used new-caller)
(unless (find new-caller (c-callers used))
+ (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used)
(fifo-add (c-caller-store used) new-caller)))
(defun caller-drop (used caller)
--- /project/cells/cvsroot/cells/cells.lisp 2006/10/28 18:20:48 1.18
+++ /project/cells/cvsroot/cells/cells.lisp 2006/12/12 15:58:42 1.19
@@ -76,7 +76,11 @@
`t))))
(defmacro without-c-dependency (&body body)
- `(let (*call-stack*) , at body))
+ `(call-without-c-dependency (lambda () , at body)))
+
+(defun call-without-c-dependency (fn)
+ (let (*call-stack*); *no-tell*)
+ (funcall fn)))
(export! .cause)
--- /project/cells/cvsroot/cells/cells.lpr 2006/11/13 05:28:08 1.24
+++ /project/cells/cvsroot/cells/cells.lpr 2006/12/12 15:58:42 1.25
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cells/cvsroot/cells/constructors.lisp 2006/11/13 05:28:08 1.13
+++ /project/cells/cvsroot/cells/constructors.lisp 2006/12/12 15:58:42 1.14
@@ -62,7 +62,7 @@
:rule (c-lambda , at body)
, at args))
-(export! c?once c?n-until)
+(export! c?once c?n-until c?1)
(defmacro c?once (&body body)
`(make-c-dependent
:code '(without-c-dependency , at body)
@@ -70,6 +70,9 @@
:value-state :unevaluated
:rule (c-lambda (without-c-dependency , at body))))
+(defmacro c?1 (&body body)
+ `(c?once , at body))
+
(defmacro c?dbg (&body body)
`(make-c-dependent
:code ',body
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/11/13 05:28:08 1.11
+++ /project/cells/cvsroot/cells/defmodel.lisp 2006/12/12 15:58:42 1.12
@@ -23,10 +23,14 @@
(assert (not (find class directsupers))() "~a cannot be its own superclass" class)
`(progn
(eval-when (:compile-toplevel :execute :load-toplevel)
- (setf (get ',class :cell-types) nil))
- ;
- ; define slot macros before class so they can appear in initforms and default-initargs
- ;
+ (setf (get ',class :cell-types) nil)
+ (setf (get ',class 'slots-excluded-from-persistence)
+ ',(loop for slotspec in slotspecs
+ unless (and (getf (cdr slotspec) :ps t)
+ (getf (cdr slotspec) :persistable t))
+ collect (car slotspec))))
+ ;; define slot macros before class so they can appear in
+ ;; initforms and default-initargs
,@(delete nil
(loop for slotspec in slotspecs
nconcing (destructuring-bind
@@ -54,6 +58,8 @@
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
+ (remf ias :persistable)
+ (remf ias :ps)
;; We handle accessor below
(when (getf ias :cell t)
(remf ias :reader)
@@ -120,6 +126,8 @@
(defun defmd-canonicalize-slot (slotname
&key
(cell nil cell-p)
+ (ps t ps-p)
+ (persistable t persistable-p)
(owning nil owning-p)
(type nil type-p)
(initform nil initform-p)
@@ -133,6 +141,8 @@
(list* slotname :initarg initarg
(append
(when cell-p (list :cell cell))
+ (when ps-p (list :ps ps))
+ (when persistable-p (list :persistable persistable))
(when owning-p (list :owning owning))
(when type-p (list :type type))
(when initform-p (list :initform initform))
@@ -158,7 +168,7 @@
((keywordp (car spec))
(assert (find (car spec) '(:documentation :metaclass)))
(push spec class-options))
- ((find (cadr spec) '(:initarg :type :cell :initform :allocation :reader :writer :accessor :documentation))
+ ((find (cadr spec) '(:initarg :type :ps :persistable :cell :initform :allocation :reader :writer :accessor :documentation))
(push (apply 'defmd-canonicalize-slot spec) slots))
(t ;; shortform (slotname initform &rest slotdef-key-values)
(push (apply 'defmd-canonicalize-slot
@@ -186,4 +196,4 @@
(ccc 42 :allocation :class)
(ddd (c-in nil) :cell :ephemeral)
:superx 42 ;; default-initarg
- (:documentation "as if!")))
\ No newline at end of file
+ (:documentation "as if!")))
--- /project/cells/cvsroot/cells/link.lisp 2006/11/03 13:37:10 1.21
+++ /project/cells/cvsroot/cells/link.lisp 2006/12/12 15:58:42 1.22
@@ -22,12 +22,18 @@
(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
for known in (cd-useds caller)
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/13 05:28:08 1.32
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/12/12 15:58:42 1.33
@@ -55,10 +55,14 @@
(when (eq :eternal-rest (md-state s))
(break "model ~a is dead at ~a" s key)))
-(defun ensure-value-is-current (c debug-id caller)
- (declare (ignorable debug-id caller))
+(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
+ ; dependencies are up-to-date before deciding if it itself is up-to-date
+ ;
+ (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 caller)
+ (trc nil "ensure-value-is-current > entry" 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))
@@ -87,7 +91,7 @@
(or (check-reversed (cdr useds))
(let ((used (car useds)))
(ensure-value-is-current used :nested c)
- (trc nil "comparing pulses (caller, used, used-changed): " c debug-id used (c-pulse-last-changed used))
+ (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
(when (> (c-pulse-last-changed used)(c-pulse c))
(trc nil "used changed and newer !!!!!!" c debug-id used)
t))))))
@@ -246,8 +250,8 @@
(c-value-state c) :valid
(c-state c) :awake)
-
- (case (cd-optimize c)
+ (case (and (typep c 'c-dependent)
+ (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))))
@@ -273,8 +277,8 @@
(not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
(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))
+ ;; (when (trcp c) (break "go optimizing ~a" c))
+ (trc nil "optimizing away" c (c-state c))
(count-it :c-optimized)
(setf (c-state c) :optimized-away)
@@ -283,7 +287,7 @@
(unless entry
(describe c))
(c-assert entry)
- (trc c "c-optimize-away?! moving cell to flushed list" c)
+ (trc nil "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))))
More information about the Cells-cvs
mailing list