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

Modified Files: cells-manifesto.txt cells.lisp defpackage.lisp initialize.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp trc-eko.lisp Log Message: Mostly differentiating new *depender* from CAR of *call-stack* so we can clear former to get without-c-dependency behavior without clearing *call-stack*, in turn to detect cyclic calculation even if doing a without-c-dependency.

--- /project/cells/cvsroot/cells/cells-manifesto.txt 2008/02/16 08:00:59 1.12 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/03/15 15:18:34 1.13 @@ -43,7 +43,7 @@ (defobserver enabled ((self menu-item) new-value old-value old-value-bound?) (menu-item-set (c-ptr self) (if new-value 1 0)))

-ie, Somr model attributes must be propagated outside the model as they change, and observers +ie, Some model attributes must be propagated outside the model as they change, and observers are callbacks we can provide to handle change.

Motivation --- /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 +++ /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25 @@ -78,6 +78,11 @@ `(c-break "failed assertion: ~a" ',assertion)))))

(defvar *call-stack* nil) +(defvar *depender* nil) +;; 2008-03-15: *depender* let's us differentiate between the call stack and +;; and dependency. The problem with overloading *call-stack* with both roles +;; is that we miss cyclic reentrance when we use without-c-dependency in a +;; rule to get "once" behavior or just when fm-traversing to find someone

(defmacro def-c-trace (model-type &optional slot cell-type) `(defmethod trcp ((self ,(case cell-type @@ -92,7 +97,7 @@ `(call-without-c-dependency (lambda () ,@body)))

(defun call-without-c-dependency (fn) - (let (*call-stack*) + (let (*depender*) (funcall fn)))

(export! .cause) --- /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10 +++ /project/cells/cvsroot/cells/defpackage.lisp 2008/03/15 15:18:34 1.11 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/03/15 15:18:34 1.11 @@ -39,13 +39,13 @@ (ephemeral-reset c)))

(defmethod awaken-cell ((c c-ruled)) - (let (*call-stack*) + (let (*depender*) (calculate-and-set c)))

#+cormanlisp ; satisfy CormanCL bug (defmethod awaken-cell ((c c-dependent)) - (let (*call-stack*) - (trc nil "awaken-cell c-dependent clearing *call-stack*" c) + (let (*depender*) + (trc nil "awaken-cell c-dependent clearing *depender*" c) (calculate-and-set c)))

(defmethod awaken-cell ((c c-drifter)) --- /project/cells/cvsroot/cells/link.lisp 2008/01/29 04:29:52 1.25 +++ /project/cells/cvsroot/cells/link.lisp 2008/03/15 15:18:34 1.26 @@ -18,17 +18,17 @@

(in-package :cells)

-(defun record-caller (used &aux (caller (car *call-stack*))) +(defun record-caller (used) (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) + (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used) (return-from record-caller nil)) - (trc nil "record-caller entry: used=" used :caller caller) - #+cool (when (and (eq :ccheck (md-name (c-model caller))) + (trc nil "record-caller entry: used=" used :caller *depender*) + #+cool (when (and (eq :ccheck (md-name (c-model *depender*))) (eq :cview (md-name (c-model used)))) (break "bingo")) (multiple-value-bind (used-pos useds-len) (loop with u-pos - for known in (cd-useds caller) + for known in (cd-useds *depender*) counting known into length when (eq used known) do @@ -37,20 +37,20 @@ finally (return (values (when u-pos (- length u-pos)) length)))

(when (null used-pos) - (trc nil "c-link > new caller,used " caller used) + (trc nil "c-link > new caller,used " *depender* used) (count-it :new-used) (setf used-pos useds-len) - (push used (cd-useds caller)) - (caller-ensure used caller) ;; 060604 experiment was in unlink + (push used (cd-useds *depender*)) + (caller-ensure used *depender*) ;; 060604 experiment was in unlink )

(handler-case - (setf (sbit (cd-usage caller) used-pos) 1) + (setf (sbit (cd-usage *depender*) used-pos) 1) (type-error (error) (declare (ignorable error)) - (setf (cd-usage caller) - (adjust-array (cd-usage caller) (+ used-pos 16) :initial-element 0)) - (setf (sbit (cd-usage caller) used-pos) 1)))) + (setf (cd-usage *depender*) + (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0)) + (setf (sbit (cd-usage *depender*) used-pos) 1)))) used)

--- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40 @@ -53,7 +53,7 @@ (prog1 (with-integrity () (ensure-value-is-current c :c-read nil)) - (when (car *call-stack*) + (when *depender* (record-caller c))))

(defun chk (s &optional (key 'anon)) @@ -131,7 +131,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) + (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) nil) v)))

@@ -178,6 +178,7 @@

(defun calculate-and-link (c) (let ((*call-stack* (cons c *call-stack*)) + (*depender* c) (*defer-changes* t)) (assert (typep c 'c-ruled)) #+shhh (trc c "calculate-and-link" c) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 @@ -76,10 +76,10 @@

(when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) - (let (*call-stack* + (let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) - (trc nil "c.propagate clearing *call-stack*" c) + (trc nil "c.propagate clearing *depender*" c)

;------ debug stuff --------- ; @@ -122,7 +122,7 @@ ; expected to have side-effects, so we want to propagate fully and be sure no rule ; wants a rollback before starting with the side effects. ; - (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this + (progn ;; unless (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c))

(trc nil "c.propagate observing" c) @@ -218,6 +218,7 @@ #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) + (assert (null *depender*)) (let ((*causation* causation)) (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) @@ -235,7 +236,20 @@ (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c)) (let ((*trc-ensure* (trcp c))) - (ensure-value-is-current caller :prop-from c))))))))) + ; + ; we just c-calculate-and-set? at the first level of dependency because + ; we do not need to check the next level (as ensure-value-is-current does) + ; because we already know /this/ notifying dependency has changed, so yeah, + ; any first-level cell /has to/ recalculate. (As for ensuring other dependents + ; of the first level guy are current, that happens automatically anyway JIT on + ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would + ; very quickly decide it has to re-run, but maybe it makes the logic clearer. + ; + ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason + ; + (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse + (calculate-and-set caller)) + ))))))))

(defparameter *the-unpropagated* nil)

--- /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15 +++ /project/cells/cvsroot/cells/synapse.lisp 2008/03/15 15:18:34 1.16 @@ -22,14 +22,13 @@ (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse)))

(defmacro with-synapse (synapse-id (&rest closure-vars) &body body) - (let ((syn-id (gensym))(syn-caller (gensym))) + (let ((syn-id (gensym))) `(let* ((,syn-id ,synapse-id) - (,syn-caller (car *call-stack*)) - (synapse (or (find ,syn-id (cd-useds ,syn-caller) :key 'c-slot-name) + (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name) (let ((new-syn (let (,@closure-vars) (make-c-dependent - :model (c-model ,syn-caller) + :model (c-model *depender*) :slot-name ,syn-id :code ',body :synaptic t @@ -39,7 +38,7 @@ (prog1 (multiple-value-bind (v p) (with-integrity () - (ensure-value-is-current synapse :synapse (car *call-stack*))) + (ensure-value-is-current synapse :synapse *depender*)) (values v p)) (record-caller synapse)))))

--- /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 20:42:23 1.9 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/03/15 15:18:34 1.10 @@ -76,7 +76,7 @@ *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) - (format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) + ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) (setf *last-trc* (get-internal-real-time)) (format stream "~a" s) (let (pkwp)