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)
26 (:export #:dep #:depp #:make-dep #:dep-goodp #:dep-name
29 #:dep-value #:dep-make-bad #:dep-bad #:dep-try
33 ;;;--------------------------------------------------------------------------
36 (defconstant +value+ 1
37 "Flag: dep's value is up-to-date.")
39 "Flag: dep is known as a dependent on its dependencies.")
40 (defconstant +changed+ 4
41 "Flag: dep has changed in the current recomputation phase.")
42 (defconstant +recomputing+ 8
43 "Flag: dep is currently being recomputed.")
44 (defconstant +queued+ 16
45 "Flag: dep is currently on the queue for recomputation.")
47 (defconstant .bad. '.bad.
48 "Magical value used to indicate bad deps.")
50 ;;;--------------------------------------------------------------------------
51 ;;; Global and special variables.
53 (defvar *generation* (list '*generation*)
54 "Generation marker, used to remember when we last updated a particular dep.
55 Essentially, if the dep's generation matches *GENERATION* then it doesn't
56 need updating again.")
58 (defvar *evaluating-dep* nil
59 "The dep currently being evaluated. This is bound only during the call of
60 a value-function, and is used to track the dependencies implied during the
61 function's evaluation.")
63 (defvar *state* :ready
64 "The current state. It may be any of:
66 * :READY -- the usual state: everything is up-to-date and correct.
68 * :FROZEN -- the state used to evaluate the body of WITH-DEPS-FROZEN.
69 Deps may be assigned values, but their dependents are not immediately
72 * :RECOMPUTING -- the state imposed while updating dependents.")
74 (defvar *delayed-operations* nil
75 "A queue of operations delayed by WITH-DEPS-FROZEN. Only available in the
78 (defvar *pending-deps* nil
79 "A queue of deps pending recomputation. This is bound to a queue during
80 recomputation and restored afterwards, so it can also be used as a flag to
81 detect whether recomputation is happening.
83 Deps on the queue are always in the current generation, and have the
86 ;;;--------------------------------------------------------------------------
89 (defstruct (dep (:predicate depp)
90 (:constructor %make-dep))
91 "There are two kinds of `dep', though we use the same object type for both.
92 A leaf dep has no dependencies, and its value is set explicitly by the
93 programmer. A non-leaf dep has a value /function/, which computes the
94 dep's value as a function of other deps' values. The dependencies don't
95 need to be declared in advance, or remain constant over time.
97 When not during a recomputation phase (i.e., when `stable'), a dep is
98 either `good' (i.e., it has a value) or `bad'. An attempt to read the
99 value of a bad dep results in a throw of `bad-dep'. Badness propagates
100 automatically during recomputation phases."
101 (%value .bad. :type t)
103 (value-function nil :type (or function null))
104 (value-predicate #'eql :type function)
105 (%flags 0 :type (unsigned-byte 8))
106 (generation *generation* :type list)
107 (listeners nil :type list)
108 (dependents nil :type list)
109 (dependencies nil :type list)
110 (weak-pointer nil :type t))
112 ;;;--------------------------------------------------------------------------
115 (declaim (inline dep-flags))
116 (defun dep-flags (dep)
117 "Return the current flags of DEP.
119 The flags are fetched from the object if we're in a recomputation phase
120 and the object's generation is current. Otherwise the object's flags are
121 out of date, and we make up a better set."
122 (cond ((eq *state* :ready) (logior +value+ +deps+))
123 ((eq (dep-generation dep) *generation*) (dep-%flags dep))
124 ((not (dep-value-function dep)) (logior +value+ +deps+))
127 (declaim (inline (setf dep-flags)))
128 (defun (setf dep-flags) (flags dep)
129 "Set the DEP's flags.
131 This doesn't do anything else like force DEP's generation."
132 (setf (dep-%flags dep) flags))
134 (defun update-dep (dep value)
135 "Modify the value of DEP.
137 If DEP's value is now different (according to its badness or
138 value-predicate) then return true; otherwise return false."
139 (let ((old-value (dep-%value dep)))
140 (if (if (eq value .bad.)
142 (and (not (eq old-value .bad.))
143 (funcall (dep-value-predicate dep) value old-value)))
145 (progn (setf (dep-%value dep) value) t))))
147 (defun new-dep-value (dep)
148 "Recompute and return the value of DEP, or .BAD. if the dep is bad.
150 This function is very minimal. The caller expected to deal with many
151 aspects of caring for and feeding DEP. In particular:
153 * Non-local exits (except throwing DEP-BAD) are not handled here.
155 * We assume that DEP is already in the current generation, and has its
156 +RECOMPUTING+ flag set.
158 * The caller is responsible for setting the current flags afterwards."
160 (let ((*evaluating-dep* dep))
161 (setf (dep-dependencies dep) nil)
162 (funcall (dep-value-function dep)))))
164 (defun propagate-to-dependents (dep)
165 "Notify the dependents of DEP of a change to its value.
167 We assume that DEP is up-to-date in the current generation, and has
168 correct flags (at least +VALUE+ and +CHANGED+, and maybe +DEPS+).
169 Dependents of DEP are enqueued for recomputation. The DEP's dependents
170 are forced into the current generation and enqueued, and the dependents
171 list is cleared ready to be repopulated. The DEP's listener functions are
173 (dolist (dweak (dep-dependents dep))
174 (let ((d (weak-pointer-value dweak)))
176 (let ((flags (dep-flags d)))
177 (unless (plusp (logand flags (logior +queued+ +deps+)))
178 (enqueue d *pending-deps*)
179 (setf (dep-generation d) *generation*
180 (dep-flags d) (logior (logand flags +value+)
182 (setf (dep-dependents dep) nil)
183 (dolist (listener (dep-listeners dep))
186 (defun recompute-dep-value (dep)
187 "Recompute the value of DEP.
189 Returns true if DEP's value actually changed, or nil otherwise. On exit,
190 the DEP's +VALUE+ and +DEPS+ flags are set, and +CHANGED+ is set if the
191 value actually changed.
193 We assume that DEP's dependencies are up-to-date already, and that DEP's
194 +RECOMPUTING+ flag is set. In the former case, DEP's dependents and
195 listeners are notified, using PROPAGATE-TO-DEPENDENTS."
196 (let ((winning nil) (queued (logand (dep-%flags dep) +queued+)))
197 (flet ((update (value)
198 (cond ((update-dep dep value)
199 (setf (dep-flags dep) (logior +value+ +deps+ +changed+
201 (propagate-to-dependents dep)
204 (setf (dep-flags dep) (logior +value+ +deps+ queued))
207 (prog1 (update (new-dep-value dep)) (setf winning t))
208 (unless winning (update .bad.))))))
210 (defun force-dep-value (dep)
211 "Arrange for DEP to have a current value.
213 Returns true if the DEP's value has changed in this recomputation phase,
216 If DEP is already has a good value, then we just use that; the return
217 value is determined by the +CHANGED+ flag. Otherwise, we set
218 +RECOMPUTING+ (in order to trap circularities) and force the values of
219 DEP's dependencies in turn. If any of them returned true then we have to
220 explicitly recompute DEP (so we do); otherwise we can leave it as it is."
221 (let ((flags (dep-flags dep)))
222 (cond ((plusp (logand flags +recomputing+))
223 (error "Ouch! Circular dependency detected."))
224 ((plusp (logand flags +value+))
225 (plusp (logand flags +changed+)))
227 (setf (dep-generation dep) *generation*
228 (dep-flags dep) (logior (logand flags +queued+)
230 (if (some #'force-dep-value (dep-dependencies dep))
231 (recompute-dep-value dep)
232 (progn (setf (dep-flags dep) flags) nil))))))
234 (defun %dep-value (dep)
235 "Do the difficult work of retrieving the current value of a DEP."
236 (when *evaluating-dep*
237 (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
238 (pushnew dep (dep-dependencies *evaluating-dep*)))
239 (force-dep-value 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.)
251 (defun dep-goodp (dep)
252 "Answer whether DEP is good."
253 (when (eq *state* :recomputing)
254 (force-dep-value dep))
255 (not (eq (dep-%value dep) .bad.)))
257 (defmacro dep-try (expr &body body)
258 "Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
259 (let ((block-name (gensym "TRY")))
262 (return-from ,block-name ,expr))
266 "Call from a value-function: indicates that the dep should marked as bad."
267 (throw 'dep-bad nil))
269 (defun recompute-pending-deps ()
270 "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
272 We bind *STATE* to :RECOMPUTING during the process."
273 (let ((*state* :recomputing))
275 (loop (when (queue-emptyp *pending-deps*)
277 (let* ((dep (dequeue *pending-deps*))
278 (flags (dep-%flags dep)))
279 (setf (dep-%flags dep) (logandc2 flags +queued+))
280 (cond ((zerop (logand flags +value+))
281 (recompute-dep-value dep))
282 ((zerop (logand flags +deps+))
284 (setf (dep-%flags dep) (logior flags +deps+))))))
285 (loop (when (queue-emptyp *pending-deps*)
287 (let ((d (dequeue *pending-deps*)))
288 (setf (dep-%value d) .bad.))))))
290 (defun with-deps-frozen* (thunk &key delay)
291 "Invoke THUNK in the :FROZEN state. See WITH-DEPS-FROZEN for full
298 (error "This really isn't a good time."))
299 (enqueue thunk *delayed-operations*))
301 (let ((*state* :frozen)
302 (*delayed-operations* (make-queue))
303 (*pending-deps* (make-queue)))
304 (setf *generation* (list '*generation*))
305 (multiple-value-prog1 (funcall thunk)
306 (loop (recompute-pending-deps)
307 (when (queue-emptyp *delayed-operations*)
309 (funcall (dequeue *delayed-operations*))))))))
311 (defmacro with-deps-frozen ((&key delay) &body body)
312 "Evaluate BODY in the :FROZEN state.
314 In the :FROZEN state, recomutation is deferred. If the current state is
315 :READY, then we enter :FROZEN, evaluate the BODY, and then enter
316 :RECOMPUTING to fix up the dependency graph. If the current state is
317 :FROZEN, we do nothing particularly special. Finally, if the current
318 state is :RECOMPUTING then the behaviour depends on the value of
319 the :DELAY argument: if false, an error is signalled; if true, the
320 evaluation is postponed until the end of the recomputation.
322 This macro has four immediate uses.
324 * Firstly, it's actually the only way to trigger recomputation at all.
325 It's invoked behind the scenes to do the right thing.
327 * If you're making a large number of updates without data dependencies
328 then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
329 and only having a single recomputation phase.
331 * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
332 You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
333 assignment until later. Deferred operations take place in the order
334 in which they were requested.
336 * Finally, you can use it to force a number of deps to hold given values
337 simultaneously, despite their value-functions disagreeing."
338 `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
340 (defun (setf dep-value) (value dep)
341 "Assign the VALUE to the DEP, forcing recomputation if necessary."
343 (when (update-dep dep value)
344 (setf (dep-generation dep) *generation*
345 (dep-flags dep) (logior +value+ +changed+))
346 (propagate-to-dependents dep)))
349 (defun dep-make-bad (dep)
350 "Mark DEP as being bad."
351 (setf (dep-value dep) .bad.))
353 (defun dep-add-listener (dep func)
354 "Add a listener function FUNC to the DEP. The FUNC is called each time the
355 DEP's value (or good/bad state) changes. It is called with no arguments,
356 and its return value is ignored."
357 (push func (dep-listeners dep)))
359 (defun make-dep (&rest args)
360 "Create a new DEP object. There are two basic argument forms:
362 (:value &optional OBJECT)
363 Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
364 dep is initially bad. The keyword :LEAF is accepted as a synonym.
367 Return a non-leaf dep whose value is computed by FUNCTION.
369 Additionally, if the first argument is something other than :VALUE or
370 :FUNCTION (ideally not a keyword, for forward compatibility), then the
371 first argument is inspected: if it's a function, then a function dep is
372 retuerned (as if you'd specified :function); otherwise a leaf dep is
375 Finally, it's possible to specify both :VALUE and :FUNCTION
376 simultaneously; this will set the initial values as requested, but
377 recompute them as necessary. It is possible to establish dependency
378 cycles, but you need to suppress recomputation in order to do this
379 correctly -- see the DELAY-RECOMPUTING-DEPS macro.
381 If no arguments are given, a bad leaf dep is returned."
383 (flet ((arg () (if args (pop args)
384 (error "Not enough arguments to MAKE-DEP."))))
386 ;; Sort out the arguments.
394 (let ((indicator (pop args)))
397 (setf value (if args (pop args) .bad.)
400 (setf function (arg)))
402 (setf predicate (arg)))
406 (push (arg) listeners))
408 (cond ((functionp indicator)
409 (setf function indicator))
411 (setf value indicator
413 (unless (or valuep function)
416 ;; Create the object appropriately.
417 (let ((dep (%make-dep :value-function function
421 :%flags (logior (if valuep +value+ 0)
422 (if function +queued+ +deps+)
424 :value-predicate predicate
425 :generation *generation*)))
426 (setf (dep-weak-pointer dep) (make-weak-pointer dep))
429 (enqueue dep *pending-deps*)))
432 (defun install-dep-syntax (&optional (readtable *readtable*))
433 "Installs into the given READTABLE some syntactic shortcuts:
435 ?FORM -> (dep-value FORM)
436 Extract (or modify, for a leaf dep) the value of the dep indicated by
439 #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
440 Return a derived dep whose value function computes the given FORMs
441 (as an implicit PROGN)
443 Returns the READTABLE."
444 (set-macro-character #\?
445 (lambda (stream char)
446 (declare (ignore char))
447 (list 'dep-value (read stream t nil t)))
449 (set-syntax-from-char #\] #\) readtable readtable)
450 (set-dispatch-macro-character #\# #\[
451 (lambda (stream arg char)
452 (declare (ignore arg char))
455 ,@(read-delimited-list #\]
462 (defmethod print-object ((dep dep) stream)
463 (print-unreadable-object (dep stream :type t :identity t)
464 (pprint-logical-block (stream nil)
465 (let ((flags (dep-flags dep))
466 (value (dep-%value dep)))
467 (cond ((zerop (logand flags +value+))
468 (write-string "#<out-of-date>" stream))
470 (write-string "#<bad>" stream))
472 (write value :stream stream)))
474 (format stream " ~_~S ~@_~W" :name (dep-name dep)))
475 (when (zerop (logand flags +deps+))
476 (format stream " ~_~S" :recompute-deps))
477 (when (plusp (logand flags +queued+))
478 (format stream " ~_~S" :queued))
479 (when (plusp (logand flags +changed+))
480 (format stream " ~_~S" :changed))))))
482 ;;;--------------------------------------------------------------------------
487 (defparameter x (make-dep :name 'x 1))
488 (defparameter y (make-dep :name 'y 2))
489 (defparameter z (make-dep :name 'z
490 (lambda () (+ (dep-value x) (dep-value y)))))
491 (defparameter w (make-dep :name 'w
492 (lambda () (* (dep-value x) (dep-value z)))))
493 (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
494 (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
495 (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
499 (defparameter a (make-dep :name 'a 1))
500 (defparameter b (make-dep :name 'b 2))
501 (defparameter c (make-dep :name 'c
502 (lambda () (1+ (dep-value a)))))
503 (defparameter d (make-dep :name 'd
504 (lambda () (* (dep-value c) (dep-value b)))))
505 (defparameter e (make-dep :name 'e
506 (lambda () (- (dep-value d) (dep-value a)))))
507 ;; a b c = a + 1 d = c*b e = d - a
510 (values (dep-value e)
512 (setf (dep-value a) 4)
520 (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
521 y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
524 (trace with-deps-frozen* update-dep new-dep-value force-dep-value
525 recompute-dep-value recompute-pending-deps propagate-to-dependents
528 ;;;----- That's all, folks --------------------------------------------------