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
27 #:delay-recomputing-deps
29 #:dep-value #:dep-make-bad #:dep-bad #:dep-try
33 ;;;--------------------------------------------------------------------------
36 (defvar *generation* (list '*generation*)
37 "Generation marker, used to remember when we last updated a particular dep.
38 Essentially, if the dep's generation matches *GENERATION* then it doesn't
39 need updating again.")
41 (defvar *evaluating-dep* nil
42 "The dep currently being evaluated. This is bound only during the call of
43 a value-func, and is used to track the dependencies implied during the
44 function's evaluation.")
46 (defvar *pending-deps* nil
47 "A queue of deps pending recomputation. This is bound to a queue during
48 recomputation and restored afterwards, so it can also be used as a flag to
49 detect whether recomputation is happening.")
51 (defstruct (dep (:predicate depp)
52 (:constructor %make-dep))
53 "There are two kinds of `dep', though we use the same object type for both.
54 A leaf dep has no dependencies, and its value is set explicitly by the
55 programmer. A non-leaf dep has a value /function/, which computes the
56 dep's value as a function of other deps' values. The dependencies don't
57 need to be declared in advance, or remain constant over time.
59 When not during a recomputation phase (i.e., when `stable'), a dep is
60 either `good' (i.e., it has a value) or `bad'. An attempt to read the
61 value of a bad dep results in a throw of `bad-dep'. Badness propagates
62 automatically during recomputation phases."
64 (value-func nil :type (or function null))
65 (value-predicate #'eql :type function)
66 (goodp nil :type boolean)
67 (state :pending :type (member :stable :pending :recomputing))
68 (generation *generation* :type list)
69 (listeners nil :type list)
70 (dependents nil :type list)
71 (weak-pointer nil :type t))
74 "Call when DEP's value (or good/bad state) has changed. Marks the
75 dependents of DEP as :pending, if they're currently :stable, and then
76 clears the dependent list. Also invokes DEP's listener functions."
77 (setf (dep-generation dep) *generation*)
78 (dolist (dweak (dep-dependents dep))
79 (let ((d (weak-pointer-value dweak)))
80 (when (and d (eq (dep-state d) :stable))
81 (enqueue d *pending-deps*)
82 (setf (dep-state d) :pending))))
83 (setf (dep-dependents dep) nil)
84 (dolist (l (dep-listeners dep))
87 (defun update-dep (dep value &optional (goodp t))
88 "Modify the value of DEP. If GOODP is t, then mark it as good and store
89 VALUE is its new value; otherwise mark it bad. If DEP's value is now
90 different (according to its value-predicate) then return true; otherwise
92 (setf (dep-state dep) :stable)
95 (progn (setf (dep-goodp dep) nil) t)
98 (funcall (dep-value-predicate dep) value (dep-%value dep)))
101 (setf (dep-goodp dep) t
102 (dep-%value dep) value)
105 (defun recompute-dep (dep)
106 "Recompute the value of DEP. This function is careful to trap nonlocal
107 transfers from the value-func."
108 (unless (eq (dep-generation dep) *generation*)
112 (setf (dep-state dep) :recomputing)
113 (when (update-dep dep (let ((*evaluating-dep*
114 (dep-weak-pointer dep)))
115 (funcall (dep-value-func dep))))
119 (when (update-dep dep nil nil)
122 (defun recompute-deps ()
123 "Recompute all the pending deps, and any others that depend on them."
125 (loop (when (queue-emptyp *pending-deps*)
127 (let ((dep (dequeue *pending-deps*)))
128 (when (eq (dep-state dep) :pending)
129 (recompute-dep dep))))
130 (loop (when (queue-emptyp *pending-deps*)
132 (let ((d (dequeue *pending-deps*)))
133 (setf (dep-state d) :stable
134 (dep-goodp d) nil)))))
136 (defun ensure-dep-has-value (dep)
137 "Ensure that DEP has a stable value. If DEP is currently computing,
139 (ecase (dep-state dep)
144 (error "Ouch! Cyclic dependency."))))
146 (defun pulse-dep (dep)
147 "Notifies DEP of a change in its value. If a recomputation phase is
148 currently under way, queue the dependents and leave fixing things up to
149 the outer loop; otherwise start up a recomputation phase."
150 (setf *generation* (list '*generation*))
153 (when (dep-value-func dep)
155 (let ((*evaluating-dep* (dep-weak-pointer dep)))
156 (funcall (dep-value-func dep)))))))
159 (let ((*pending-deps* (make-queue)))
163 (defun (setf dep-value) (value dep)
164 "Set DEP's value to be VALUE (and mark it as being good)."
165 (when (update-dep dep value) (pulse-dep dep))
168 (defun dep-make-bad (dep)
169 "Mark DEP as being bad."
170 (when (update-dep dep nil nil) (pulse-dep dep)))
172 (defun dep-add-listener (dep func)
173 "Add a listener function FUNC to the DEP. The FUNC is called each time the
174 DEP's value (or good/bad state) changes. It is called with no arguments,
175 and its return value is ignored."
176 (push func (dep-listeners dep)))
178 (defun dep-value (dep)
179 "Retrieve the current value from DEP."
180 (when *evaluating-dep*
181 (pushnew *evaluating-dep* (dep-dependents dep)))
182 (ensure-dep-has-value dep)
183 (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil)))
185 (defun make-dep (&rest args)
186 "Create a new DEP object. There are two basic argument forms:
188 (:value &optional OBJECT)
189 Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
190 dep is initially bad. The keyword :leaf is accepted as a synonym.
193 Return a non-leaf dep whose value is computed by FUNCTION.
195 Additionally, if the first argument is something other than :VALUE or
196 :FUNCTION (ideally not a keyword, for forward compatibility), then the
197 first argument is inspected: if it's a function, then a function dep is
198 retuerned (as if you'd specified :function); otherwise a leaf dep is
201 Finally, it's possible to specify both :value and :function
202 simultaneously; this will set the initial values as requested, but
203 recompute them as necessary. It is possible to establish dependency
204 cycles, but you need to suppress recomputation in order to do this
205 correctly -- see the DELAY-RECOMPUTING-DEPS macro.
207 If no arguments are given, a bad leaf dep is returned."
209 (flet ((arg () (if args (pop args)
210 (error "Not enough arguments to MAKE-DEP."))))
212 ;; Sort out the arguments.
218 (let ((indicator (pop args)))
222 (setf value (pop args) valuep t)
223 (setf value nil valuep t)))
225 (setf function (arg)))
227 (setf predicate (arg)))
229 (cond ((functionp indicator)
230 (setf function indicator))
232 (setf value indicator valuep t)))))))
234 ;; Create the object appropriately.
235 (let ((dep (%make-dep :value-func function
237 :state (if valuep :stable :pending)
238 :value-predicate predicate
239 :generation (if function nil *generation*)
241 (setf (dep-weak-pointer dep) (make-weak-pointer dep))
242 (cond ((not function) t)
243 (valuep (pulse-dep dep))
245 (enqueue dep *pending-deps*))
247 (let ((*pending-deps* (make-queue)))
248 (enqueue dep *pending-deps*)
252 (defmacro dep-try (expr &body body)
253 "Evaluate EXPR. If it throws dep-bad then evaluate BODY instead."
254 (let ((block-name (gensym "TRY")))
257 (return-from ,block-name ,expr))
261 "Call from a value-func: indicates that the dep should marked as bad."
262 (throw 'dep-bad nil))
264 (defun delay-recomputing-deps* (thunk)
265 "The guts of the DELAY-RECOMPUTING-DEPS macro. Evaluate THUNK without
266 immediately updating dependencies until THUNK finishes. Returns the
270 (let ((*pending-deps* (make-queue)))
271 (setf *generation* (list '*generation*))
272 (multiple-value-prog1
276 (defmacro delay-recomputing-deps (&body body)
277 "Evaluate BODY, but delay recomputing any deps until the BODY completes
280 Note that deps can report incorrect values while delayed recomputation is
281 in effect. In the current implementation, the direct dependents of a leaf
282 dep whose value has changed will be correctly marked as pending (and
283 recomputed as necessary); higher-level dependents won't be noticed until
284 the direct dependents are recomputed.
286 It can be used to apply a number of updates simultaneously to the system.
287 This is useful for two reasons:
289 * Firstly, it avoids the computational overheads of propagating changes
290 repeatedly, so it can be used as a simple optimization.
292 * Secondly, and perhaps more interestingly, it allows the values of
293 mutually-dependent deps to be set simultaneously, even though the
294 values being set may not be compatible with the deps' value
296 `(delay-recomputing-deps* #'(lambda () ,@body)))
298 (defun install-dep-syntax (&optional (readtable *readtable*))
299 "Installs into the given READTABLE some syntactic shortcuts:
301 ?FORM -> (dep-value FORM)
302 Extract (or modify, for a leaf dep) the value of the dep indicated by
305 #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
306 Return a derived dep whose value function computes the given FORMs
307 (as an implicit PROGN)
309 Returns the READTABLE."
310 (set-macro-character #\?
311 (lambda (stream char)
312 (declare (ignore char))
313 (list 'dep-value (read stream t nil t)))
315 (set-syntax-from-char #\] #\) readtable readtable)
316 (set-dispatch-macro-character #\# #\[
317 (lambda (stream arg char)
318 (declare (ignore arg char))
321 ,@(read-delimited-list #\]
327 (defmethod print-object ((dep dep) stream)
328 (print-unreadable-object (dep stream :type t :identity t)
329 (cond ((not (eq (dep-state dep) :stable))
330 (format stream "~S" (dep-state dep)))
332 (format stream "~S ~W" :good (dep-%value dep)))
334 (format stream "~S" :bad)))))
338 (defparameter x (make-dep 1))
339 (defparameter y (make-dep 2))
340 (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
341 (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
342 (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
343 (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
344 (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
346 ;;;----- That's all, folks --------------------------------------------------