Commit | Line | Data |
---|---|---|
2626af66 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Maintenance and recalculation of dependent values | |
4 | ;;; | |
5 | ;;; (c) 2008 Mark Wooding | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
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. | |
14 | ;;; | |
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. | |
19 | ;;; | |
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. | |
23 | ||
24 | (defpackage #:dep | |
5f61c961 | 25 | (:use #:common-lisp #:queue #:weak) |
2626af66 | 26 | (:export #:dep #:depp #:make-dep #:dep-goodp |
23bc61bd | 27 | #:delay-recomputing-deps |
2626af66 MW |
28 | #:install-dep-syntax |
29 | #:dep-value #:dep-make-bad #:dep-bad #:dep-try | |
30 | #:dep-add-listener)) | |
31 | (in-package #:dep) | |
32 | ||
33 | ;;;-------------------------------------------------------------------------- | |
34 | ;;; Dependencies. | |
35 | ||
23bc61bd MW |
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.") | |
40 | ||
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.") | |
45 | ||
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.") | |
50 | ||
2626af66 MW |
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. | |
58 | ||
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." | |
63 | (%value nil :type t) | |
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)) | |
23bc61bd | 68 | (generation *generation* :type list) |
2626af66 | 69 | (listeners nil :type list) |
5f61c961 MW |
70 | (dependents nil :type list) |
71 | (weak-pointer nil :type t)) | |
2626af66 | 72 | |
2626af66 MW |
73 | (defun kick-dep (dep) |
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." | |
23bc61bd | 77 | (setf (dep-generation dep) *generation*) |
5f61c961 MW |
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)))) | |
2626af66 MW |
83 | (setf (dep-dependents dep) nil) |
84 | (dolist (l (dep-listeners dep)) | |
85 | (funcall l))) | |
86 | ||
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 | |
91 | return false." | |
92 | (setf (dep-state dep) :stable) | |
93 | (cond ((not goodp) | |
94 | (if (dep-goodp dep) | |
95 | (progn (setf (dep-goodp dep) nil) t) | |
96 | nil)) | |
97 | ((and (dep-goodp dep) | |
98 | (funcall (dep-value-predicate dep) value (dep-%value dep))) | |
99 | nil) | |
100 | (t | |
101 | (setf (dep-goodp dep) t | |
102 | (dep-%value dep) value) | |
103 | t))) | |
104 | ||
105 | (defun recompute-dep (dep) | |
106 | "Recompute the value of DEP. This function is careful to trap nonlocal | |
107 | transfers from the value-func." | |
23bc61bd MW |
108 | (unless (eq (dep-generation dep) *generation*) |
109 | (let ((winning nil)) | |
110 | (unwind-protect | |
111 | (catch 'dep-bad | |
112 | (setf (dep-state dep) :recomputing) | |
5f61c961 MW |
113 | (when (update-dep dep (let ((*evaluating-dep* |
114 | (dep-weak-pointer dep))) | |
23bc61bd MW |
115 | (funcall (dep-value-func dep)))) |
116 | (kick-dep dep)) | |
117 | (setf winning t)) | |
118 | (unless winning | |
119 | (when (update-dep dep nil nil) | |
120 | (kick-dep dep))))))) | |
2626af66 MW |
121 | |
122 | (defun recompute-deps () | |
123 | "Recompute all the pending deps, and any others that depend on them." | |
124 | (unwind-protect | |
125 | (loop (when (queue-emptyp *pending-deps*) | |
126 | (return)) | |
127 | (let ((dep (dequeue *pending-deps*))) | |
128 | (when (eq (dep-state dep) :pending) | |
129 | (recompute-dep dep)))) | |
130 | (loop (when (queue-emptyp *pending-deps*) | |
131 | (return)) | |
132 | (let ((d (dequeue *pending-deps*))) | |
133 | (setf (dep-state d) :stable | |
134 | (dep-goodp d) nil))))) | |
135 | ||
136 | (defun ensure-dep-has-value (dep) | |
137 | "Ensure that DEP has a stable value. If DEP is currently computing, | |
138 | signals an error." | |
139 | (ecase (dep-state dep) | |
140 | (:stable) | |
141 | (:pending | |
142 | (recompute-dep dep)) | |
143 | (:recomputing | |
144 | (error "Ouch! Cyclic dependency.")))) | |
145 | ||
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." | |
23bc61bd MW |
150 | (setf *generation* (list '*generation*)) |
151 | (flet ((kick (dep) | |
152 | (kick-dep dep) | |
153 | (when (dep-value-func dep) | |
154 | (catch 'dep-bad | |
5f61c961 | 155 | (let ((*evaluating-dep* (dep-weak-pointer dep))) |
23bc61bd MW |
156 | (funcall (dep-value-func dep))))))) |
157 | (if *pending-deps* | |
158 | (kick dep) | |
159 | (let ((*pending-deps* (make-queue))) | |
160 | (kick dep) | |
161 | (recompute-deps))))) | |
2626af66 MW |
162 | |
163 | (defun (setf dep-value) (value dep) | |
164 | "Set DEP's value to be VALUE (and mark it as being good)." | |
23bc61bd | 165 | (when (update-dep dep value) (pulse-dep dep)) |
2626af66 MW |
166 | value) |
167 | ||
168 | (defun dep-make-bad (dep) | |
169 | "Mark DEP as being bad." | |
23bc61bd | 170 | (when (update-dep dep nil nil) (pulse-dep dep))) |
2626af66 MW |
171 | |
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))) | |
177 | ||
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))) | |
184 | ||
185 | (defun make-dep (&rest args) | |
186 | "Create a new DEP object. There are two basic argument forms: | |
187 | ||
23bc61bd | 188 | (:value &optional OBJECT) |
2626af66 | 189 | Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the |
23bc61bd | 190 | dep is initially bad. The keyword :leaf is accepted as a synonym. |
2626af66 MW |
191 | |
192 | (:function FUNCTION) | |
193 | Return a non-leaf dep whose value is computed by FUNCTION. | |
194 | ||
23bc61bd MW |
195 | Additionally, if the first argument is something other than :VALUE or |
196 | :FUNCTION (ideally not a keyword, for forward compatibility), then the | |
2626af66 MW |
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 | |
199 | returned. | |
200 | ||
23bc61bd MW |
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. | |
206 | ||
2626af66 MW |
207 | If no arguments are given, a bad leaf dep is returned." |
208 | ||
23bc61bd MW |
209 | (flet ((arg () (if args (pop args) |
210 | (error "Not enough arguments to MAKE-DEP.")))) | |
2626af66 MW |
211 | |
212 | ;; Sort out the arguments. | |
23bc61bd MW |
213 | (let ((value nil) |
214 | (valuep nil) | |
5f61c961 | 215 | (predicate #'eql) |
23bc61bd MW |
216 | (function nil)) |
217 | (do () ((endp args)) | |
218 | (let ((indicator (pop args))) | |
5f61c961 MW |
219 | (case indicator |
220 | ((:value :leaf) | |
221 | (if args | |
222 | (setf value (pop args) valuep t) | |
223 | (setf value nil valuep t))) | |
224 | (:function | |
225 | (setf function (arg))) | |
226 | (:predicate | |
227 | (setf predicate (arg))) | |
228 | (t | |
229 | (cond ((functionp indicator) | |
230 | (setf function indicator)) | |
231 | (t | |
232 | (setf value indicator valuep t))))))) | |
2626af66 MW |
233 | |
234 | ;; Create the object appropriately. | |
23bc61bd MW |
235 | (let ((dep (%make-dep :value-func function |
236 | :%value value | |
237 | :state (if valuep :stable :pending) | |
5f61c961 | 238 | :value-predicate predicate |
23bc61bd MW |
239 | :generation (if function nil *generation*) |
240 | :goodp valuep))) | |
5f61c961 | 241 | (setf (dep-weak-pointer dep) (make-weak-pointer dep)) |
23bc61bd MW |
242 | (cond ((not function) t) |
243 | (valuep (pulse-dep dep)) | |
244 | (*pending-deps* | |
245 | (enqueue dep *pending-deps*)) | |
246 | (t | |
2626af66 MW |
247 | (let ((*pending-deps* (make-queue))) |
248 | (enqueue dep *pending-deps*) | |
23bc61bd MW |
249 | (recompute-deps)))) |
250 | dep)))) | |
2626af66 MW |
251 | |
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"))) | |
255 | `(block ,block-name | |
256 | (catch 'dep-bad | |
257 | (return-from ,block-name ,expr)) | |
258 | ,@body))) | |
259 | ||
260 | (defun dep-bad () | |
261 | "Call from a value-func: indicates that the dep should marked as bad." | |
262 | (throw 'dep-bad nil)) | |
263 | ||
264 | (defun delay-recomputing-deps* (thunk) | |
23bc61bd | 265 | "The guts of the DELAY-RECOMPUTING-DEPS macro. Evaluate THUNK without |
2626af66 MW |
266 | immediately updating dependencies until THUNK finishes. Returns the |
267 | value(s) of THUNK." | |
268 | (if *pending-deps* | |
269 | (funcall thunk) | |
270 | (let ((*pending-deps* (make-queue))) | |
23bc61bd | 271 | (setf *generation* (list '*generation*)) |
2626af66 MW |
272 | (multiple-value-prog1 |
273 | (funcall thunk) | |
274 | (recompute-deps))))) | |
275 | ||
276 | (defmacro delay-recomputing-deps (&body body) | |
277 | "Evaluate BODY, but delay recomputing any deps until the BODY completes | |
278 | execution. | |
279 | ||
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. | |
285 | ||
23bc61bd MW |
286 | It can be used to apply a number of updates simultaneously to the system. |
287 | This is useful for two reasons: | |
288 | ||
289 | * Firstly, it avoids the computational overheads of propagating changes | |
290 | repeatedly, so it can be used as a simple optimization. | |
291 | ||
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 | |
295 | functions." | |
296 | `(delay-recomputing-deps* #'(lambda () ,@body))) | |
2626af66 MW |
297 | |
298 | (defun install-dep-syntax (&optional (readtable *readtable*)) | |
299 | "Installs into the given READTABLE some syntactic shortcuts: | |
300 | ||
301 | ?FORM -> (dep-value FORM) | |
302 | Extract (or modify, for a leaf dep) the value of the dep indicated by | |
303 | FORM. | |
304 | ||
305 | #[FORM ...] -> (make-dep :funcion (lambda () FORM ...)) | |
306 | Return a derived dep whose value function computes the given FORMs | |
307 | (as an implicit PROGN) | |
308 | ||
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))) | |
314 | readtable) | |
315 | (set-syntax-from-char #\] #\) readtable readtable) | |
316 | (set-dispatch-macro-character #\# #\[ | |
317 | (lambda (stream arg char) | |
318 | (declare (ignore arg char)) | |
319 | `(make-dep :function | |
320 | (lambda () | |
321 | ,@(read-delimited-list #\] | |
322 | stream | |
323 | t)))) | |
324 | readtable) | |
325 | readtable) | |
326 | ||
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))) | |
331 | ((dep-goodp dep) | |
332 | (format stream "~S ~W" :good (dep-%value dep))) | |
333 | (t | |
334 | (format stream "~S" :bad))))) | |
335 | ||
336 | #+ test | |
337 | (progn | |
5f61c961 MW |
338 | (defparameter x (make-dep 1)) |
339 | (defparameter y (make-dep 2)) | |
2626af66 MW |
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)))) | |
345 | ||
346 | ;;;----- That's all, folks -------------------------------------------------- |