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*) ,@body)) + `(call-without-c-dependency (lambda () ,@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 ,@body) ,@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 ,@body) @@ -70,6 +70,9 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body))))

+(defmacro c?1 (&body body) + `(c?once ,@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))))