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."
192 (let ((winning nil) (queued (logand (dep-%flags dep) +queued+)))
193 (flet ((update (value)
194 (cond ((update-dep dep value)
195 (setf (dep-flags dep) (logior +value+ +deps+ +changed+
197 (propagate-to-dependents dep)
200 (setf (dep-flags dep) (logior +value+ +deps+ queued))
203 (prog1 (update (new-dep-value dep)) (setf winning t))
204 (unless winning (update .bad.))))))
206 (defun force-dep-value (dep)
207 "Arrange for DEP to have a current value.
209 Returns true if the DEP's value has changed in this recomputation phase,
212 If DEP is already has a good value, then we just use that; the return
213 value is determined by the +CHANGED+ flag. Otherwise, we set
214 +RECOMPUTING+ (in order to trap circularities) and force the values of
215 DEP's dependencies in turn. If any of them returned true then we have to
216 explicitly recompute DEP (so we do); otherwise we can leave it as it is."
217 (let ((flags (dep-flags dep)))
218 (cond ((plusp (logand flags +recomputing+))
219 (error "Ouch! Circular dependency detected."))
220 ((plusp (logand flags +value+))
221 (plusp (logand flags +changed+)))
223 (setf (dep-generation dep) *generation*
224 (dep-flags dep) (logior (logand flags +queued+)
226 (if (some #'force-dep-value (dep-dependencies dep))
227 (recompute-dep-value dep)
228 (progn (setf (dep-flags dep) flags) nil))))))
230 (defun %dep-value (dep)
231 "Do the difficult work of retrieving the current value of a DEP.
233 This is the unhappy path of `dep-value'."
234 (force-dep-value dep)
235 (when *evaluating-dep*
236 (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
237 (pushnew dep (dep-dependencies *evaluating-dep*))))
240 (declaim (inline dep-value))
241 (defun dep-value (dep)
242 "Retrieve the current value from DEP."
243 (when (eq *state* :recomputing)
245 (let ((value (dep-%value dep)))
247 (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.)))
258 (defmacro dep-try (expr &body body)
259 "Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
260 (let ((block-name (gensym "TRY")))
263 (return-from ,block-name ,expr))
268 "Call from a value-function: indicates that the dep should marked as bad."
269 (throw 'dep-bad nil))
271 (defun recompute-pending-deps ()
272 "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
274 We bind *STATE* to :RECOMPUTING during the process."
275 (let ((*state* :recomputing))
277 (loop (when (queue-emptyp *pending-deps*)
279 (let* ((dep (dequeue *pending-deps*))
280 (flags (dep-%flags dep)))
281 (setf (dep-%flags dep) (logandc2 flags +queued+))
282 (cond ((zerop (logand flags +value+))
283 (recompute-dep-value dep))
284 ((zerop (logand flags +deps+))
286 (setf (dep-%flags dep) (logior flags +deps+))))))
287 (loop (when (queue-emptyp *pending-deps*)
289 (let ((d (dequeue *pending-deps*)))
290 (setf (dep-%value d) .bad.))))))
292 (defun with-deps-frozen* (thunk &key delay)
293 "Invoke THUNK in the :FROZEN state. See WITH-DEPS-FROZEN for full
300 (error "This really isn't a good time."))
301 (enqueue thunk *delayed-operations*))
303 (let ((*state* :frozen)
304 (*delayed-operations* (make-queue))
305 (*pending-deps* (make-queue)))
306 (setf *generation* (list '*generation*))
307 (multiple-value-prog1 (funcall thunk)
308 (loop (recompute-pending-deps)
309 (when (queue-emptyp *delayed-operations*)
311 (funcall (dequeue *delayed-operations*))))))))
313 (export 'with-deps-frozen)
314 (defmacro with-deps-frozen ((&key delay) &body body)
315 "Evaluate BODY in the :FROZEN state.
317 In the :FROZEN state, recomutation is deferred. If the current state is
318 :READY, then we enter :FROZEN, evaluate the BODY, and then enter
319 :RECOMPUTING to fix up the dependency graph. If the current state is
320 :FROZEN, we do nothing particularly special. Finally, if the current
321 state is :RECOMPUTING then the behaviour depends on the value of
322 the :DELAY argument: if false, an error is signalled; if true, the
323 evaluation is postponed until the end of the recomputation.
325 This macro has four immediate uses.
327 * Firstly, it's actually the only way to trigger recomputation at all.
328 It's invoked behind the scenes to do the right thing.
330 * If you're making a large number of updates without data dependencies
331 then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
332 and only having a single recomputation phase.
334 * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
335 You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
336 assignment until later. Deferred operations take place in the order
337 in which they were requested.
339 * Finally, you can use it to force a number of deps to hold given values
340 simultaneously, despite their value-functions disagreeing."
341 `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
343 (defun (setf dep-value) (value dep)
344 "Assign the VALUE to the DEP, forcing recomputation if necessary."
346 (when (update-dep dep value)
347 (setf (dep-generation dep) *generation*
348 (dep-flags dep) (logior +value+ +changed+))
349 (propagate-to-dependents dep)))
352 (export 'dep-make-bad)
353 (defun dep-make-bad (dep)
354 "Mark DEP as being bad."
355 (setf (dep-value dep) .bad.))
357 (export 'dep-add-listener)
358 (defun dep-add-listener (dep func)
359 "Add a listener function FUNC to the DEP. The FUNC is called each time the
360 DEP's value (or good/bad state) changes. It is called with no arguments,
361 and its return value is ignored."
362 (push func (dep-listeners dep)))
365 (defun make-dep (&rest args)
366 "Create a new DEP object. There are two basic argument forms:
368 (:value &optional OBJECT)
369 Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
370 dep is initially bad. The keyword :LEAF is accepted as a synonym.
373 Return a non-leaf dep whose value is computed by FUNCTION.
375 Additionally, if the first argument is something other than :VALUE or
376 :FUNCTION (ideally not a keyword, for forward compatibility), then the
377 first argument is inspected: if it's a function, then a function dep is
378 retuerned (as if you'd specified :function); otherwise a leaf dep is
381 Finally, it's possible to specify both :VALUE and :FUNCTION
382 simultaneously; this will set the initial values as requested, but
383 recompute them as necessary. It is possible to establish dependency
384 cycles, but you need to suppress recomputation in order to do this
385 correctly -- see the DELAY-RECOMPUTING-DEPS macro.
387 If no arguments are given, a bad leaf dep is returned."
389 (flet ((arg () (if args (pop args)
390 (error "Not enough arguments to MAKE-DEP."))))
392 ;; Sort out the arguments.
400 (let ((indicator (pop args)))
403 (setf value (if args (pop args) .bad.)
406 (setf function (arg)))
408 (setf predicate (arg)))
412 (push (arg) listeners))
414 (cond ((functionp indicator)
415 (setf function indicator))
417 (setf value indicator
419 (unless (or valuep function)
422 ;; Create the object appropriately.
423 (let ((dep (%make-dep :value-function function
427 :%flags (logior (if valuep +value+ 0)
428 (if function +queued+ +deps+)
430 :value-predicate predicate
431 :generation *generation*)))
432 (setf (dep-weak-pointer dep) (make-weak-pointer dep))
435 (enqueue dep *pending-deps*)))
438 (export 'install-dep-syntax)
439 (defun install-dep-syntax (&optional (readtable *readtable*))
440 "Installs into the given READTABLE some syntactic shortcuts:
442 ?FORM -> (dep-value FORM)
443 Extract (or modify, for a leaf dep) the value of the dep indicated by
446 #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
447 Return a derived dep whose value function computes the given FORMs
448 (as an implicit PROGN)
450 Returns the READTABLE."
451 (set-macro-character #\?
452 (lambda (stream char)
453 (declare (ignore char))
454 (list 'dep-value (read stream t nil t)))
456 (set-syntax-from-char #\] #\) readtable readtable)
457 (set-dispatch-macro-character #\# #\[
458 (lambda (stream arg char)
459 (declare (ignore arg char))
462 ,@(read-delimited-list #\]
469 (defmethod print-object ((dep dep) stream)
470 (print-unreadable-object (dep stream :type t :identity t)
471 (pprint-logical-block (stream nil)
472 (let ((flags (dep-flags dep))
473 (value (dep-%value dep)))
474 (cond ((zerop (logand flags +value+))
475 (write-string "#<out-of-date>" stream))
477 (write-string "#<bad>" stream))
479 (write value :stream stream)))
481 (format stream " ~_~S ~@_~W" :name (dep-name dep)))
482 (when (zerop (logand flags +deps+))
483 (format stream " ~_~S" :recompute-deps))
484 (when (plusp (logand flags +queued+))
485 (format stream " ~_~S" :queued))
486 (when (plusp (logand flags +changed+))
487 (format stream " ~_~S" :changed))))))
489 ;;;--------------------------------------------------------------------------
494 (defparameter x (make-dep :name 'x 1))
495 (defparameter y (make-dep :name 'y 2))
496 (defparameter z (make-dep :name 'z
497 (lambda () (+ (dep-value x) (dep-value y)))))
498 (defparameter w (make-dep :name 'w
499 (lambda () (* (dep-value x) (dep-value z)))))
500 (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
501 (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
502 (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
506 (defparameter a (make-dep :name 'a 1))
507 (defparameter b (make-dep :name 'b 2))
508 (defparameter c (make-dep :name 'c
509 (lambda () (1+ (dep-value a)))))
510 (defparameter d (make-dep :name 'd
511 (lambda () (* (dep-value c) (dep-value b)))))
512 (defparameter e (make-dep :name 'e
513 (lambda () (- (dep-value d) (dep-value a)))))
514 ;; a b c = a + 1 d = c*b e = d - a
517 (values (dep-value e)
519 (setf (dep-value a) 4)
527 (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
528 y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
531 (trace with-deps-frozen* update-dep new-dep-value force-dep-value
532 recompute-dep-value recompute-pending-deps propagate-to-dependents
535 ;;;----- That's all, folks --------------------------------------------------