/[cells]/cells/propagate.lisp
ViewVC logotype

Contents of /cells/propagate.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Sun Oct 12 01:21:07 2008 UTC (5 years, 6 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.37: +34 -27 lines
Just trying to get a patch in for record-caller
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 #|
3
4 Cells -- Automatic Dataflow Managememnt
5
6 Copyright (C) 1995, 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :cells)
20
21 ;----------------- change detection ---------------------------------
22
23 (defun c-no-news (c new-value old-value)
24 ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue)
25 (bif (test (c-unchanged-test (c-model c) (c-slot-name c)))
26 (funcall test new-value old-value)
27 (eql new-value old-value)))
28
29 (defmacro def-c-unchanged-test ((class slotname) &body test)
30 `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname)))
31 ,@test))
32
33 (defmethod c-unchanged-test (self slotname)
34 (declare (ignore self slotname))
35 nil)
36
37 ; --- data pulse (change ID) management -------------------------------------
38
39 (defparameter *one-pulse?* nil)
40
41 (defun data-pulse-next (pulse-info)
42 (declare (ignorable pulse-info))
43 (unless *one-pulse?*
44 ;(trc "dp-next> " (1+ *data-pulse-id*) pulse-info)
45 #+chill (when *c-debug*
46 (push (list :data-pulse-next pulse-info) *istack*))
47 (incf *data-pulse-id*)))
48
49 (defun c-currentp (c)
50 (eql (c-pulse c) *data-pulse-id*))
51
52 (defun c-pulse-update (c key)
53 (declare (ignorable key))
54 (unless (find key '(:valid-uninfluenced))
55 (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)))
56 (assert (>= *data-pulse-id* (c-pulse c)) ()
57 "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c)
58 (setf (c-pulse c) *data-pulse-id*))
59
60 ;--------------- propagate ----------------------------
61 ; n.b. the cell argument may have been optimized away,
62 ; though it is still receiving final processing here.
63
64 (defparameter *per-cell-handler* nil)
65
66 (defun c-propagate (c prior-value prior-value-supplied)
67 (when *one-pulse?*
68 (when *per-cell-handler*
69 (funcall *per-cell-handler* c prior-value prior-value-supplied)
70 (return-from c-propagate)))
71
72 (count-it :cpropagate)
73 (setf (c-pulse-last-changed c) *data-pulse-id*)
74
75 (when prior-value
76 (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
77 (let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers
78 (*c-prop-depth* (1+ *c-prop-depth*))
79 (*defer-changes* t))
80 (trc nil "c.propagate clearing *depender*" c)
81
82 ;------ debug stuff ---------
83 ;
84 (when *stop*
85 (princ #\.)(princ #\!)
86 (return-from c-propagate))
87 (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
88 #+slow (trc nil "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
89 (when *c-debug*
90 (when (> *c-prop-depth* 250)
91 (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
92 (when (> *c-prop-depth* 300)
93 (c-break "c.propagate looping ~c" c)))
94
95 ; --- manifest new value as needed ---
96 ;
97 ; 20061030 Trying not.to.be first because doomed instances may be interested in callers
98 ; who will decide to propagate. If a family instance kids slot is changing, a doomed kid
99 ; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid
100 ; to look at its siblings (say a view instance being deleted from a stack who looks to the psib
101 ; pb to decide its own pt), the doomed kid will still have a parent but not be in its kids slot
102 ; when it goes looking for a sibling relative to its position.
103 ;
104 (when (and prior-value-supplied
105 prior-value
106 (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))
107 (trc nil "c.propagate> contemplating lost" (qci c))
108 (flet ((listify (x) (if (listp x) x (list x))))
109 (bif (lost (set-difference (listify prior-value) (listify (c-value c))))
110 (progn
111 (trc nil "prop nailing owned!!!!!!!!!!!" (qci c) :lost (length lost)) ;; :leaving (c-value c))
112 (loop for l in lost
113 when (numberp l)
114 do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c)
115 (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))))
116 (mapcar 'not-to-be lost))
117 (trc nil "no owned lost!!!!!"))))
118
119 ; propagation to callers jumps back in front of client slot-value-observe handling in cells3
120 ; because model adopting (once done by the kids change handler) can now be done in
121 ; shared-initialize (since one is now forced to supply the parent to make-instance).
122 ;
123 ; we wnat it here to support (eventually) state change rollback. change handlers are
124 ; expected to have side-effects, so we want to propagate fully and be sure no rule
125 ; wants a rollback before starting with the side effects.
126 ;
127 (progn ;; unless (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
128 (c-propagate-to-callers c))
129
130 (trc nil "c.propagate observing" c)
131
132 ; this next assertion is just to see if we can ever come this way twice. If so, just
133 ; make it a condition on whether to observe
134 (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c))
135 (setf (c-pulse-observed c) *data-pulse-id*)
136 (slot-value-observe (c-slot-name c) (c-model c)
137 (c-value c) prior-value prior-value-supplied c))
138
139
140 ;
141 ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
142 ; let the fn decide if C really is ephemeral. Note that it might be possible to leave
143 ; this out and use the datapulse to identify obsolete ephemerals and clear them
144 ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe,
145 ; thinking that that always followed propagation to callers. It would also make
146 ; debugging easier in that I could find the last ephemeral value in the inspector.
147 ; would this be bad for persistent CLOS, in which a DB would think there was still a link
148 ; between two records until the value actually got cleared?
149 ;
150 (ephemeral-reset c)))
151
152 ; --- slot change -----------------------------------------------------------
153
154 (defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args))))
155 (when aroundp (setf args (cdr args)))
156 (when (find slotname '(value kids))
157 (break "d: did you mean .value or .kids when you coded ~a?" slotname))
158 (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value)
159 (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c))
160 &body output-body) args
161 `(progn
162 (eval-when (:compile-toplevel :load-toplevel :execute)
163 (setf (get ',slotname :output-defined) t))
164 ,(if (eql (last1 output-body) :test)
165 (let ((temp1 (gensym))
166 (loc-self (gensym)))
167 `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn)
168 ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
169 (let ((,temp1 (bump-output-count ,slotname))
170 (,loc-self ,(if (listp self-arg)
171 (car self-arg)
172 self-arg)))
173 (when (and ,oldvargboundp ,oldvarg)
174 (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg))
175 (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg))))
176 `(defmethod slot-value-observe
177 #-(or cormanlisp) ,(if aroundp :around 'progn)
178 ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
179 (declare (ignorable
180 ,@(flet ((arg-name (arg-spec)
181 (etypecase arg-spec
182 (list (car arg-spec))
183 (atom arg-spec))))
184 (list (arg-name self-arg)(arg-name new-varg)
185 (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg)))))
186 ,@output-body)))))
187
188 (defmacro bump-output-count (slotname) ;; pure test func
189 `(if (get ',slotname :outputs)
190 (incf (get ',slotname :outputs))
191 (setf (get ',slotname :outputs) 1)))
192
193 ; --- recalculate dependents ----------------------------------------------------
194
195
196 (defmacro cll-outer (val &body body)
197 `(let ((outer-val ,val))
198 ,@body))
199
200 (defmacro cll-inner (expr)
201 `(,expr outer-val))
202
203 (export! cll-outer cll-inner)
204
205 (defun c-propagate-to-callers (c)
206 ;
207 ; We must defer propagation to callers because of an edge case in which:
208 ; - X tells A to recalculate
209 ; - A asks B for its current value
210 ; - B must recalculate because it too uses X
211 ; - if B propagates to its callers after recalculating instead of deferring it
212 ; - B might tell H to reclaculate, where H decides this time to use A
213 ; - but A is in the midst of recalculating, and cannot complete until B returns.
214 ; but B is busy eagerly propagating. "This time" is important because it means
215 ; there is no way one can reliably be sure H will not ask for A
216 ;
217 (when (find-if-not (lambda (caller)
218 (and (c-lazy caller) ;; slight optimization
219 (member (c-lazy caller) '(t :always :once-asked))))
220 (c-callers c))
221 (let ((causation (cons c *causation*))) ;; in case deferred
222 #+slow (trc nil "c.propagate-to-callers > queueing notifying callers" (c-callers c))
223 (with-integrity (:tell-dependents c)
224 (assert (null *call-stack*))
225 (assert (null *depender*))
226 ;
227 (if (mdead (c-model c))
228 (trc nil "WHOAA!!!! dead by time :tell-deps dispatched; bailing" c)
229 (let ((*causation* causation))
230 (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c))
231 #+c-debug (dolist (caller (c-callers c))
232 (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
233 #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
234 (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
235 (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
236 (member (c-lazy caller) '(t :always :once-asked)))
237 (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
238 ))
239 (dolist (caller (c-callers c))
240 (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
241 (block do-a-caller
242 (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
243 (member (c-lazy caller) '(t :always :once-asked)))
244 (unless (find c (cd-useds caller))
245 (trc "WHOA!!!! Bailing on Known caller:" caller :does-not-in-its-used c)
246 (return-from do-a-caller))
247 #+slow (trc nil "propagating to caller is used" c :caller caller (c-currentp c))
248 (let ((*trc-ensure* (trcp c)))
249 ;
250 ; we just calculate-and-set at the first level of dependency because
251 ; we do not need to check the next level (as ensure-value-is-current does)
252 ; because we already know /this/ notifying dependency has changed, so yeah,
253 ; any first-level cell /has to/ recalculate. (As for ensuring other dependents
254 ; of the first level guy are current, that happens automatically anyway JIT on
255 ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would
256 ; very quickly decide it has to re-run, but maybe it makes the logic clearer.
257 ;
258 ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason
259 ;
260 (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse
261 (calculate-and-set caller :propagate c))))))))))))
262
263 (defparameter *the-unpropagated* nil)
264
265 (defmacro with-one-datapulse ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body)
266 `(call-with-one-datapulse (lambda () ,@body)
267 ,@(when per-cell? `(:per-cell (lambda (c prior-value prior-value-boundp)
268 (declare (ignorable c prior-value prior-value-boundp))
269 ,per-cell)))
270 ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally)))))
271
272 (defun call-with-one-datapulse
273 (f &key
274 (per-cell (lambda (c prior-value prior-value?)
275 (unless (find c *the-unpropagated* :key 'car)
276 (pushnew (list c prior-value prior-value?) *the-unpropagated*))))
277 (finally (lambda (cs)
278 (print `(finally sees ,*data-pulse-id* ,cs))
279 ;(trace c-propagate ensure-value-is-current)
280 (loop for (c prior-value prior-value?) in (nreverse cs) do
281 (c-propagate c prior-value prior-value?)))))
282 (assert (not *one-pulse?*))
283 (data-pulse-next :client-prop)
284 (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*)
285 (funcall finally
286 (let ((*one-pulse?* t)
287 (*per-cell-handler* per-cell)
288 (*the-unpropagated* nil))
289 (funcall f)
290 *the-unpropagated*)))
291

  ViewVC Help
Powered by ViewVC 1.1.5