[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Fri Feb 1 03:18:36 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv4024
Modified Files:
cells.lpr integrity.lisp md-slot-value.lisp propagate.lisp
Log Message:
version 1.0 of multiple updates in one datapulse
--- /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28
+++ /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29
@@ -1,8 +1,8 @@
-;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
-(defpackage :cells)
+(defpackage :CELLS)
(define-project :name :cells
:modules (list (make-instance 'module :name "defpackage.lisp")
@@ -36,16 +36,17 @@
:runtime-modules nil
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:local-name-info)
- :build-flags '(:allow-debug :purify)
+ :include-flags (list :local-name-info)
+ :build-flags (list :allow-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+cx +t \"Initializing\""
- :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
- :on-initialization 'cells::test
+ :on-initialization 'cells::tcprop
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 22:29:06 1.19
+++ /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20
@@ -27,7 +27,7 @@
(defmacro with-integrity ((&optional opcode defer-info debug) &rest body)
(when opcode
(assert (find opcode *ufb-opcodes*) ()
- "Invalid second value to with-integrity: ~a" opcode))
+ "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*))
`(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info)
(declare (ignorable opcode defer-info))
,(when debug
@@ -55,8 +55,7 @@
*defer-changes*)
(trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
(when (or (zerop *data-pulse-id*)
- (eq opcode :change)
- )
+ (eq opcode :change))
(eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
(data-pulse-next (cons opcode defer-info))))
(prog1
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/31 03:30:17 1.38
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39
@@ -218,8 +218,6 @@
;
; --- data flow propagation -----------
;
-
- (setf (c-pulse-last-changed c) *data-pulse-id*)
(without-c-dependency
(c-propagate c prior-value t)))))))
@@ -245,7 +243,6 @@
(md-slot-value-assume c new-value nil))
(*defer-changes*
- (print `(cweird ,c ,(type-of c)))
(c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
(t
@@ -277,12 +274,10 @@
(return-from md-slot-value-assume absorbed-value))
; --- slot maintenance ---
- (when (eq (c-state c) :optimized-away)
- (break "bongo one ~a flush ~a" c (flushed? c)))
+
(unless (c-synaptic c)
(md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
- (when (eq (c-state c) :optimized-away)
- (break "bongo two ~a flush ~a" c (flushed? c)))
+
; --- cell maintenance ---
(setf
(c-value c) absorbed-value
@@ -298,7 +293,6 @@
; --- data flow propagation -----------
(unless (eq propagation-code :no-propagate)
(trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value )
- (setf (c-pulse-last-changed c) *data-pulse-id*)
(c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound))
absorbed-value)))
--- /project/cells/cvsroot/cells/propagate.lisp 2008/01/31 03:30:17 1.29
+++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30
@@ -36,10 +36,13 @@
; --- data pulse (change ID) management -------------------------------------
+(defparameter *client-is-propagating* nil)
+
(defun data-pulse-next (pulse-info)
(declare (ignorable pulse-info))
- (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info)
- (incf *data-pulse-id*))
+ (unless *client-is-propagating*
+ (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info)
+ (incf *data-pulse-id*)))
(defun c-currentp (c)
(eql (c-pulse c) *data-pulse-id*))
@@ -59,28 +62,37 @@
; though it is still receiving final processing here.
;
+
+(defparameter *per-cell-handler* nil)
+
(defun c-propagate (c prior-value prior-value-supplied)
-
- (count-it :c-propagate)
+ (when *client-is-propagating*
+ (when *per-cell-handler*
+ (funcall *per-cell-handler* c prior-value prior-value-supplied)
+ (return-from c-propagate)))
+
+ (count-it :cpropagate)
+ (setf (c-pulse-last-changed c) *data-pulse-id*)
+
(when prior-value
(assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
(let (*call-stack*
(*c-prop-depth* (1+ *c-prop-depth*))
(*defer-changes* t))
- (trc nil "c-propagate clearing *call-stack*" c)
+ (trc nil "c.propagate clearing *call-stack*" c)
;------ debug stuff ---------
;
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
- #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
+ (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
+ #+slow (trc c "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
- (trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
+ (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
(when (> *c-prop-depth* 300)
- (c-break "c-propagate looping ~c" c)))
+ (c-break "c.propagate looping ~c" c)))
; --- manifest new value as needed ---
;
@@ -94,7 +106,7 @@
(when (and prior-value-supplied
prior-value
(md-slot-owning (type-of (c-model c)) (c-slot-name c)))
- (trc nil "c-propagate> contemplating lost")
+ (trc nil "c.propagate> contemplating lost")
(flet ((listify (x) (if (listp x) x (list x))))
(bif (lost (set-difference (listify prior-value) (listify (c-value c))))
(progn
@@ -113,7 +125,7 @@
(unless nil #+not (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)
+ (trc nil "c.propagate observing" c)
; this next assertion is just to see if we can ever come this way twice. If so, just
; make it a condition on whether to observe
@@ -177,6 +189,14 @@
; --- recalculate dependents ----------------------------------------------------
+(defmacro cll-outer (val &body body)
+ `(let ((outer-val ,val))
+ , at body))
+
+(defmacro cll-inner (expr)
+ `(,expr outer-val))
+
+(export! cll-outer cll-inner)
(defun c-propagate-to-callers (c)
;
@@ -195,11 +215,11 @@
(member (c-lazy caller) '(t :always :once-asked))))
(c-callers c))
(let ((causation (cons c *causation*))) ;; in case deferred
- #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c))
+ #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
- (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c))
+ (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c))
#+c-debug (dolist (caller (c-callers c))
(assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
#+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
@@ -217,6 +237,66 @@
(let ((*trc-ensure* (trcp c)))
(ensure-value-is-current caller :prop-from c)))))))))
+(defparameter *the-unpropagated* nil)
+
+(defmacro with-client-propagation ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body)
+ `(call-with-client-propagation (lambda () , at body)
+ ,@(when per-cell? `(:per-cell (lambda (c) (declare (ignorable c)) ,per-cell)))
+ ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally)))))
+
+(defun call-with-client-propagation
+ (f &key
+ (per-cell (lambda (c prior-value prior-value?)
+ (unless (find c *the-unpropagated* :key 'car)
+ (pushnew (list c prior-value prior-value?) *the-unpropagated*))))
+ (finally (lambda (cs)
+ (print `(finally sees ,*data-pulse-id* ,cs))
+ ;(trace c-propagate ensure-value-is-current)
+ (loop for (c prior-value prior-value?) in (nreverse cs) do
+ (c-propagate c prior-value prior-value?)))))
+ (assert (not *client-is-propagating*))
+ (data-pulse-next :client-prop)
+ (trc "call-with-client-propagation bumps pulse" *data-pulse-id*)
+ (funcall finally
+ (let ((*client-is-propagating* t)
+ (*per-cell-handler* per-cell)
+ (*the-unpropagated* nil))
+ (funcall f)
+ *the-unpropagated*)))
+
+
+(defmd tcp ()
+ (left (c-in 0))
+ (top (c-in 0))
+ (right (c-in 0))
+ (bottom (c-in 0))
+ (area (c? (trc "area running")
+ (* (- (^right)(^left))
+ (- (^top)(^bottom))))))
+
+(defobserver area ()
+ (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+
+(defun tcprop ()
+ (untrace)
+ (test-prep)
+ (LET ((box (make-instance 'tcp)))
+ (trc "changing top to 10" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "not changing top" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "changing right to 10" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "not changing right" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "changing bottom to -1" *data-pulse-id*)
+ (decf (bottom box))
+ (with-client-propagation ()
+ (loop repeat 20 do
+ (trc "changing bottom by -1" *data-pulse-id*)
+ (decf (bottom box))
+ (decf (left box))))))
+
More information about the Cells-cvs
mailing list