3 ;;; Maintenance and recalculation of dependent values
5 ;;; (c) 2008 Mark Wooding
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25 (:use #:common-lisp #:queue #:weak))
28 ;;;--------------------------------------------------------------------------
31 (defconstant +value+ 1
32 "Flag: dep's value is up-to-date.")
34 "Flag: dep is known as a dependent on its dependencies.")
35 (defconstant +changed+ 4
36 "Flag: dep has changed in the current recomputation phase.")
37 (defconstant +recomputing+ 8
38 "Flag: dep is currently being recomputed.")
39 (defconstant +queued+ 16
40 "Flag: dep is currently on the queue for recomputation.")
42 (defconstant .bad. '.bad.
43 "Magical value used to indicate bad deps.")
45 ;;;--------------------------------------------------------------------------
46 ;;; Global and special variables.
48 (defvar *generation* (list '*generation*)
49 "Generation marker, used to remember when we last updated a particular dep.
50 Essentially, if the dep's generation matches *GENERATION* then it doesn't
51 need updating again.")
53 (defvar *evaluating-dep* nil
54 "The dep currently being evaluated. This is bound only during the call of
55 a value-function, and is used to track the dependencies implied during the
56 function's evaluation.")
58 (defvar *state* :ready
59 "The current state. It may be any of:
61 * :READY -- the usual state: everything is up-to-date and correct.
63 * :FROZEN -- the state used to evaluate the body of WITH-DEPS-FROZEN.
64 Deps may be assigned values, but their dependents are not immediately
67 * :RECOMPUTING -- the state imposed while updating dependents.")
69 (defvar *delayed-operations* nil
70 "A queue of operations delayed by WITH-DEPS-FROZEN. Only available in the
73 (defvar *pending-deps* nil
74 "A queue of deps pending recomputation. This is bound to a queue during
75 recomputation and restored afterwards, so it can also be used as a flag to
76 detect whether recomputation is happening.
78 Deps on the queue are always in the current generation, and have the
81 ;;;--------------------------------------------------------------------------
84 (export '(dep depp dep-name))
85 (defstruct (dep (:predicate depp)
86 (:constructor %make-dep))
87 "There are two kinds of `dep', though we use the same object type for both.
88 A leaf dep has no dependencies, and its value is set explicitly by the
89 programmer. A non-leaf dep has a value /function/, which computes the
90 dep's value as a function of other deps' values. The dependencies don't
91 need to be declared in advance, or remain constant over time.
93 When not during a recomputation phase (i.e., when `stable'), a dep is
94 either `good' (i.e., it has a value) or `bad'. An attempt to read the
95 value of a bad dep results in a throw of `bad-dep'. Badness propagates
96 automatically during recomputation phases."
97 (%value .bad. :type t)
98 (name nil :type t :read-only t)
99 (value-function nil :type (or function null) :read-only t)
100 (value-predicate #'eql :type function :read-only t)
101 (%flags 0 :type (unsigned-byte 8))
102 (generation *generation* :type list)
103 (listeners nil :type list)
104 (dependents nil :type list)
105 (dependencies nil :type list)
106 (weak-pointer nil :type t))
108 ;;;--------------------------------------------------------------------------
111 (declaim (inline dep-flags))
112 (defun dep-flags (dep)
113 "Return the current flags of DEP.
115 The flags are fetched from the object if we're in a recomputation phase
116 and the object's generation is current. Otherwise the object's flags are
117 out of date, and we make up a better set."
118 (cond ((eq *state* :ready) (logior +value+ +deps+))
119 ((eq (dep-generation dep) *generation*) (dep-%flags dep))
120 ((not (dep-value-function dep)) (logior +value+ +deps+))
123 (declaim (inline (setf dep-flags)))
124 (defun (setf dep-flags) (flags dep)
125 "Set the DEP's flags.
127 This doesn't do anything else like force DEP's generation."
128 (setf (dep-%flags dep) flags))
130 (defun update-dep (dep value)
131 "Modify the value of DEP.
133 If DEP's value is now different (according to its badness or
134 value-predicate) then return true; otherwise return false."
135 (let ((old-value (dep-%value dep)))
136 (if (if (eq value .bad.)
138 (and (not (eq old-value .bad.))
139 (funcall (dep-value-predicate dep) value old-value)))
141 (progn (setf (dep-%value dep) value) t))))
143 (defun new-dep-value (dep)
144 "Recompute and return the value of DEP, or .BAD. if the dep is bad.
146 This function is very minimal. The caller expected to deal with many
147 aspects of caring for and feeding DEP. In particular:
149 * Non-local exits (except throwing DEP-BAD) are not handled here.
151 * We assume that DEP is already in the current generation, and has its
152 +RECOMPUTING+ flag set.
154 * The caller is responsible for setting the current flags afterwards."
156 (let ((*evaluating-dep* dep))
157 (setf (dep-dependencies dep) nil)
158 (funcall (dep-value-function dep)))))
160 (defun propagate-to-dependents (dep)
161 "Notify the dependents of DEP of a change to its value.
163 We assume that DEP is up-to-date in the current generation, and has
164 correct flags (at least +VALUE+ and +CHANGED+, and maybe +DEPS+).
165 Dependents of DEP are enqueued for recomputation. The DEP's dependents
166 are forced into the current generation and enqueued, and the dependents
167 list is cleared ready to be repopulated. The DEP's listener functions are
169 (dolist (dweak (dep-dependents dep))
170 (let ((d (weak-pointer-value dweak)))
172 (let ((flags (dep-flags d)))
173 (unless (plusp (logand flags (logior +queued+ +deps+)))
174 (enqueue d *pending-deps*)
175 (setf (dep-generation d) *generation*
176 (dep-flags d) (logior (logand flags +value+)
178 (setf (dep-dependents dep) nil)
179 (dolist (listener (dep-listeners dep))
182 (defun recompute-dep-value (dep)
183 "Recompute the value of DEP.
185 Returns true if DEP's value actually changed, or nil otherwise. On exit,
186 the DEP's +VALUE+ and +DEPS+ flags are set, and +CHANGED+ is set if the
187 value actually changed.
189 We assume that DEP's dependencies are up-to-date already, and that DEP's
190 +RECOMPUTING+ flag is set. In the former case, DEP's dependents and
191 listeners are notified, using PROPAGATE-TO-DEPENDENTS."
193 (new-flags (logior (logand (dep-%flags dep) +queued+)
195 (flet ((update (value)
196 (cond ((update-dep dep value)
197 (setf (dep-flags dep) (logior new-flags +changed+))
198 (propagate-to-dependents dep)
201 (setf (dep-flags dep) new-flags)
204 (prog1 (update (new-dep-value dep)) (setf winning t))
205 (unless winning (update .bad.))))))
207 (defun force-dep-value (dep)
208 "Arrange for DEP to have a current value.
210 Returns true if the DEP's value has changed in this recomputation phase,
213 If DEP is already has a good value, then we just use that; the return
214 value is determined by the +CHANGED+ flag. Otherwise, we set
215 +RECOMPUTING+ (in order to trap circularities) and force the values of
216 DEP's dependencies in turn. If any of them returned true then we have to
217 explicitly recompute DEP (so we do); otherwise we can leave it as it is."
218 (let ((flags (dep-flags dep)))
219 (cond ((plusp (logand flags +recomputing+))
220 (error "Ouch! Circular dependency detected."))
221 ((plusp (logand flags +value+))
222 (plusp (logand flags +changed+)))
224 (setf (dep-generation dep) *generation*
225 (dep-flags dep) (logior (logand flags +queued+)
227 (if (some #'force-dep-value (dep-dependencies dep))
228 (recompute-dep-value dep)
229 (progn (setf (dep-flags dep) flags) nil))))))
231 (defun %dep-value (dep)
232 "Do the difficult work of retrieving the current value of a DEP.
234 This is the unhappy path of `dep-value'."
235 (force-dep-value dep)
236 (when *evaluating-dep*
237 (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
238 (pushnew dep (dep-dependencies *evaluating-dep*))))
241 (declaim (inline dep-value))
242 (defun dep-value (dep)
243 "Retrieve the current value from DEP."
244 (when (eq *state* :recomputing)
246 (let ((value (dep-%value dep)))
248 (throw 'dep-bad .bad.)
252 (defun dep-goodp (dep)
253 "Answer whether DEP is good."
254 (when (eq *state* :recomputing)
255 (force-dep-value dep))
256 (not (eq (dep-%value dep) .bad.)))
259 (defmacro dep-try (expr &body body)
260 "Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
261 (let ((block-name (gensym "TRY")))
264 (return-from ,block-name ,expr))
269 "Call from a value-function: indicates that the dep should marked as bad."
270 (throw 'dep-bad nil))
272 (defun recompute-pending-deps ()
273 "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
275 We bind *STATE* to :RECOMPUTING during the process."
276 (let ((*state* :recomputing))
278 (loop (when (queue-emptyp *pending-deps*)
280 (let* ((dep (dequeue *pending-deps*))
281 (flags (dep-%flags dep)))
282 (setf (dep-%flags dep) (logandc2 flags +queued+))
283 (cond ((zerop (logand flags +value+))
284 (recompute-dep-value dep))
285 ((zerop (logand flags +deps+))
287 (setf (dep-%flags dep) (logior flags +deps+))))))
288 (loop (when (queue-emptyp *pending-deps*)
290 (let ((d (dequeue *pending-deps*)))
291 (setf (dep-%value d) .bad.))))))
293 (defun with-deps-frozen* (thunk &key delay)
294 "Invoke THUNK in the :FROZEN state. See WITH-DEPS-FROZEN for full
301 (error "This really isn't a good time."))
302 (enqueue thunk *delayed-operations*))
304 (let ((*state* :frozen)
305 (*delayed-operations* (make-queue))
306 (*pending-deps* (make-queue)))
307 (setf *generation* (list '*generation*))
308 (multiple-value-prog1 (funcall thunk)
309 (loop (recompute-pending-deps)
310 (when (queue-emptyp *delayed-operations*)
312 (funcall (dequeue *delayed-operations*))))))))
314 (export 'with-deps-frozen)
315 (defmacro with-deps-frozen ((&key delay) &body body)
316 "Evaluate BODY in the :FROZEN state.
318 In the :FROZEN state, recomutation is deferred. If the current state is
319 :READY, then we enter :FROZEN, evaluate the BODY, and then enter
320 :RECOMPUTING to fix up the dependency graph. If the current state is
321 :FROZEN, we do nothing particularly special. Finally, if the current
322 state is :RECOMPUTING then the behaviour depends on the value of
323 the :DELAY argument: if false, an error is signalled; if true, the
324 evaluation is postponed until the end of the recomputation.
326 This macro has four immediate uses.
328 * Firstly, it's actually the only way to trigger recomputation at all.
329 It's invoked behind the scenes to do the right thing.
331 * If you're making a large number of updates without data dependencies
332 then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
333 and only having a single recomputation phase.
335 * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
336 You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
337 assignment until later. Deferred operations take place in the order
338 in which they were requested.
340 * Finally, you can use it to force a number of deps to hold given values
341 simultaneously, despite their value-functions disagreeing."
342 `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
344 (defun (setf dep-value) (value dep)
345 "Assign the VALUE to the DEP, forcing recomputation if necessary."
347 (when (update-dep dep value)
348 (setf (dep-generation dep) *generation*
349 (dep-flags dep) (logior +value+ +changed+))
350 (propagate-to-dependents dep)))
353 (export 'dep-make-bad)
354 (defun dep-make-bad (dep)
355 "Mark DEP as being bad."
356 (setf (dep-value dep) .bad.))
358 (export 'dep-add-listener)
359 (defun dep-add-listener (dep func)
360 "Add a listener function FUNC to the DEP. The FUNC is called each time the
361 DEP's value (or good/bad state) changes. It is called with no arguments,
362 and its return value is ignored."
363 (push func (dep-listeners dep)))
366 (defun make-dep (&rest args)
367 "Create a new DEP object. There are two basic argument forms:
369 (:value &optional OBJECT)
370 Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
371 dep is initially bad. The keyword :LEAF is accepted as a synonym.
374 Return a non-leaf dep whose value is computed by FUNCTION.
376 Additionally, if the first argument is something other than :VALUE or
377 :FUNCTION (ideally not a keyword, for forward compatibility), then the
378 first argument is inspected: if it's a function, then a function dep is
379 retuerned (as if you'd specified :function); otherwise a leaf dep is
382 Finally, it's possible to specify both :VALUE and :FUNCTION
383 simultaneously; this will set the initial values as requested, but
384 recompute them as necessary. It is possible to establish dependency
385 cycles, but you need to suppress recomputation in order to do this
386 correctly -- see the DELAY-RECOMPUTING-DEPS macro.
388 If no arguments are given, a bad leaf dep is returned."
390 (flet ((arg () (if args (pop args)
391 (error "Not enough arguments to MAKE-DEP."))))
393 ;; Sort out the arguments.
401 (let ((indicator (pop args)))
404 (setf value (if args (pop args) .bad.)
407 (setf function (arg)))
409 (setf predicate (arg)))
413 (push (arg) listeners))
415 (cond ((functionp indicator)
416 (setf function indicator))
418 (setf value indicator
420 (unless (or valuep function)
423 ;; Create the object appropriately.
424 (let ((dep (%make-dep :value-function function
428 :%flags (logior (if valuep +value+ 0)
429 (if function +queued+ +deps+)
431 :value-predicate predicate
432 :generation *generation*)))
433 (setf (dep-weak-pointer dep) (make-weak-pointer dep))
436 (enqueue dep *pending-deps*)))
439 (export 'install-dep-syntax)
440 (defun install-dep-syntax (&optional (readtable *readtable*))
441 "Installs into the given READTABLE some syntactic shortcuts:
443 ?FORM -> (dep-value FORM)
444 Extract (or modify, for a leaf dep) the value of the dep indicated by
447 #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
448 Return a derived dep whose value function computes the given FORMs
449 (as an implicit PROGN)
451 Returns the READTABLE."
452 (set-macro-character #\?
453 (lambda (stream char)
454 (declare (ignore char))
455 (list 'dep-value (read stream t nil t)))
457 (set-syntax-from-char #\] #\) readtable readtable)
458 (set-dispatch-macro-character #\# #\[
459 (lambda (stream arg char)
460 (declare (ignore arg char))
463 ,@(read-delimited-list #\]
470 (defmethod print-object ((dep dep) stream)
471 (print-unreadable-object (dep stream :type t :identity t)
472 (pprint-logical-block (stream nil)
473 (let ((flags (dep-flags dep))
474 (value (dep-%value dep)))
475 (cond ((zerop (logand flags +value+))
476 (write-string "#<out-of-date>" stream))
478 (write-string "#<bad>" stream))
480 (write value :stream stream)))
482 (format stream " ~_~S ~@_~W" :name (dep-name dep)))
483 (when (zerop (logand flags +deps+))
484 (format stream " ~_~S" :recompute-deps))
485 (when (plusp (logand flags +queued+))
486 (format stream " ~_~S" :queued))
487 (when (plusp (logand flags +changed+))
488 (format stream " ~_~S" :changed))))))
490 ;;;--------------------------------------------------------------------------
495 (defparameter x (make-dep :name 'x 1))
496 (defparameter y (make-dep :name 'y 2))
497 (defparameter z (make-dep :name 'z
498 (lambda () (+ (dep-value x) (dep-value y)))))
499 (defparameter w (make-dep :name 'w
500 (lambda () (* (dep-value x) (dep-value z)))))
501 (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
502 (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
503 (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
507 (defparameter a (make-dep :name 'a 1))
508 (defparameter b (make-dep :name 'b 2))
509 (defparameter c (make-dep :name 'c
510 (lambda () (1+ (dep-value a)))))
511 (defparameter d (make-dep :name 'd
512 (lambda () (* (dep-value c) (dep-value b)))))
513 (defparameter e (make-dep :name 'e
514 (lambda () (- (dep-value d) (dep-value a)))))
515 ;; a b c = a + 1 d = c*b e = d - a
518 (values (dep-value e)
520 (setf (dep-value a) 4)
528 (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
529 y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
532 (trace with-deps-frozen* update-dep new-dep-value force-dep-value
533 recompute-dep-value recompute-pending-deps propagate-to-dependents
536 ;;;----- That's all, folks --------------------------------------------------