[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Sat Mar 15 15:18:34 UTC 2008
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 () , at 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 (, at 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)
More information about the Cells-cvs
mailing list