| 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 |
| 25 | (:use #:common-lisp #:queue #:weak) |
| 26 | (:export #:dep #:depp #:make-dep #:dep-goodp |
| 27 | #:delay-recomputing-deps |
| 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 | |
| 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 | |
| 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)) |
| 68 | (generation *generation* :type list) |
| 69 | (listeners nil :type list) |
| 70 | (dependents nil :type list) |
| 71 | (weak-pointer nil :type t)) |
| 72 | |
| 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." |
| 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)) |
| 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." |
| 108 | (unless (eq (dep-generation dep) *generation*) |
| 109 | (let ((winning nil)) |
| 110 | (unwind-protect |
| 111 | (catch 'dep-bad |
| 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)))) |
| 116 | (kick-dep dep)) |
| 117 | (setf winning t)) |
| 118 | (unless winning |
| 119 | (when (update-dep dep nil nil) |
| 120 | (kick-dep dep))))))) |
| 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." |
| 150 | (setf *generation* (list '*generation*)) |
| 151 | (flet ((kick (dep) |
| 152 | (kick-dep dep) |
| 153 | (when (dep-value-func dep) |
| 154 | (catch 'dep-bad |
| 155 | (let ((*evaluating-dep* (dep-weak-pointer dep))) |
| 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))))) |
| 162 | |
| 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)) |
| 166 | value) |
| 167 | |
| 168 | (defun dep-make-bad (dep) |
| 169 | "Mark DEP as being bad." |
| 170 | (when (update-dep dep nil nil) (pulse-dep dep))) |
| 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 | |
| 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. |
| 191 | |
| 192 | (:function FUNCTION) |
| 193 | Return a non-leaf dep whose value is computed by FUNCTION. |
| 194 | |
| 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 |
| 199 | returned. |
| 200 | |
| 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 | |
| 207 | If no arguments are given, a bad leaf dep is returned." |
| 208 | |
| 209 | (flet ((arg () (if args (pop args) |
| 210 | (error "Not enough arguments to MAKE-DEP.")))) |
| 211 | |
| 212 | ;; Sort out the arguments. |
| 213 | (let ((value nil) |
| 214 | (valuep nil) |
| 215 | (predicate #'eql) |
| 216 | (function nil)) |
| 217 | (do () ((endp args)) |
| 218 | (let ((indicator (pop args))) |
| 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))))))) |
| 233 | |
| 234 | ;; Create the object appropriately. |
| 235 | (let ((dep (%make-dep :value-func function |
| 236 | :%value value |
| 237 | :state (if valuep :stable :pending) |
| 238 | :value-predicate predicate |
| 239 | :generation (if function nil *generation*) |
| 240 | :goodp valuep))) |
| 241 | (setf (dep-weak-pointer dep) (make-weak-pointer dep)) |
| 242 | (cond ((not function) t) |
| 243 | (valuep (pulse-dep dep)) |
| 244 | (*pending-deps* |
| 245 | (enqueue dep *pending-deps*)) |
| 246 | (t |
| 247 | (let ((*pending-deps* (make-queue))) |
| 248 | (enqueue dep *pending-deps*) |
| 249 | (recompute-deps)))) |
| 250 | dep)))) |
| 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) |
| 265 | "The guts of the DELAY-RECOMPUTING-DEPS macro. Evaluate THUNK without |
| 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))) |
| 271 | (setf *generation* (list '*generation*)) |
| 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 | |
| 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))) |
| 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 |
| 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)))) |
| 345 | |
| 346 | ;;;----- That's all, folks -------------------------------------------------- |