chiark - git - mdw - lisp/blob - dep.lisp

   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)
  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
  72 (defun kick-dep (dep)
  73   "Call when DEP's value (or good/bad state) has changed.  Marks the
  74    dependents of DEP as :pending, if they're currently :stable, and then
  75    clears the dependent list.  Also invokes DEP's listener functions."
  76   (setf (dep-generation dep) *generation*)
  77   (dolist (d (dep-dependents dep))
  78     (when (eq (dep-state d) :stable)
  79       (enqueue d *pending-deps*)
  80       (setf (dep-state d) :pending)))
  81   (setf (dep-dependents dep) nil)
  82   (dolist (l (dep-listeners dep))
  83     (funcall l)))
  84
  85 (defun update-dep (dep value &optional (goodp t))
  86   "Modify the value of DEP.  If GOODP is t, then mark it as good and store
  87    VALUE is its new value; otherwise mark it bad.  If DEP's value is now
  88    different (according to its value-predicate) then return true; otherwise
  89    return false."
  90   (setf (dep-state dep) :stable)
  91   (cond ((not goodp)
  92          (if (dep-goodp dep)
  93              (progn (setf (dep-goodp dep) nil) t)
  94              nil))
  95         ((and (dep-goodp dep)
  96               (funcall (dep-value-predicate dep) value (dep-%value dep)))
  97          nil)
  98         (t
  99          (setf (dep-goodp dep) t
 100                (dep-%value dep) value)
 101          t)))
 102
 103 (defun recompute-dep (dep)
 104   "Recompute the value of DEP.  This function is careful to trap nonlocal
 105    transfers from the value-func."
 106   (unless (eq (dep-generation dep) *generation*)
 107     (let ((winning nil))
 108       (unwind-protect
 109            (catch 'dep-bad
 110              (setf (dep-state dep) :recomputing)
 111              (when (update-dep dep (let ((*evaluating-dep* dep))
 112                                      (funcall (dep-value-func dep))))
 113                (kick-dep dep))
 114              (setf winning t))
 115         (unless winning
 116           (when (update-dep dep nil nil)
 117             (kick-dep dep)))))))
 118
 119 (defun recompute-deps ()
 120   "Recompute all the pending deps, and any others that depend on them."
 121   (unwind-protect
 122        (loop (when (queue-emptyp *pending-deps*)
 123                (return))
 124              (let ((dep (dequeue *pending-deps*)))
 125                (when (eq (dep-state dep) :pending)
 126                  (recompute-dep dep))))
 127     (loop (when (queue-emptyp *pending-deps*)
 128             (return))
 129           (let ((d (dequeue *pending-deps*)))
 130             (setf (dep-state d) :stable
 131                   (dep-goodp d) nil)))))
 132
 133 (defun ensure-dep-has-value (dep)
 134   "Ensure that DEP has a stable value.  If DEP is currently computing,
 135    signals an error."
 136   (ecase (dep-state dep)
 137     (:stable)
 138     (:pending
 139      (recompute-dep dep))
 140     (:recomputing
 141      (error "Ouch!  Cyclic dependency."))))
 142
 143 (defun pulse-dep (dep)
 144   "Notifies DEP of a change in its value.  If a recomputation phase is
 145    currently under way, queue the dependents and leave fixing things up to
 146    the outer loop; otherwise start up a recomputation phase."
 147   (setf *generation* (list '*generation*))
 148   (flet ((kick (dep)
 149            (kick-dep dep)
 150            (when (dep-value-func dep)
 151              (catch 'dep-bad
 152                (let ((*evaluating-dep* dep))
 153                  (funcall (dep-value-func dep)))))))
 154     (if *pending-deps*
 155         (kick dep)
 156         (let ((*pending-deps* (make-queue)))
 157           (kick dep)
 158           (recompute-deps)))))
 159
 160 (defun (setf dep-value) (value dep)
 161   "Set DEP's value to be VALUE (and mark it as being good)."
 162   (when (update-dep dep value) (pulse-dep dep))
 163   value)
 164
 165 (defun dep-make-bad (dep)
 166   "Mark DEP as being bad."
 167   (when (update-dep dep nil nil) (pulse-dep dep)))
 168
 169 (defun dep-add-listener (dep func)
 170   "Add a listener function FUNC to the DEP.  The FUNC is called each time the
 171    DEP's value (or good/bad state) changes.  It is called with no arguments,
 172    and its return value is ignored."
 173   (push func (dep-listeners dep)))
 174
 175 (defun dep-value (dep)
 176   "Retrieve the current value from DEP."
 177   (when *evaluating-dep*
 178     (pushnew *evaluating-dep* (dep-dependents dep)))
 179   (ensure-dep-has-value dep)
 180   (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil)))
 181
 182 (defun make-dep (&rest args)
 183   "Create a new DEP object.  There are two basic argument forms:
 184
 185    (:value &optional OBJECT)
 186         Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
 187         dep is initially bad.  The keyword :leaf is accepted as a synonym.
 188
 189    (:function FUNCTION)
 190         Return a non-leaf dep whose value is computed by FUNCTION.
 191
 192    Additionally, if the first argument is something other than :VALUE or
 193    :FUNCTION (ideally not a keyword, for forward compatibility), then the
 194    first argument is inspected: if it's a function, then a function dep is
 195    retuerned (as if you'd specified :function); otherwise a leaf dep is
 196    returned.
 197
 198    Finally, it's possible to specify both :value and :function
 199    simultaneously; this will set the initial values as requested, but
 200    recompute them as necessary.  It is possible to establish dependency
 201    cycles, but you need to suppress recomputation in order to do this
 202    correctly -- see the DELAY-RECOMPUTING-DEPS macro.
 203
 204    If no arguments are given, a bad leaf dep is returned."
 205
 206   (flet ((arg () (if args (pop args)
 207                      (error "Not enough arguments to MAKE-DEP."))))
 208
 209     ;; Sort out the arguments.
 210     (let ((value nil)
 211           (valuep nil)
 212           (function nil))
 213       (do () ((endp args))
 214         (let ((indicator (pop args)))
 215           (cond ((or (eq indicator :value)
 216                      (eq indicator :leaf))
 217                  (if args
 218                      (setf value (pop args) valuep t)
 219                      (setf value nil valuep t)))
 220                 ((eq indicator :function)
 221                  (setf function (arg)))
 222                 ((functionp indicator)
 223                  (setf function indicator))
 224                 (t
 225                  (setf value indicator valuep t)))))
 226
 227       ;; Create the object appropriately.
 228       (let ((dep (%make-dep :value-func function
 229                             :%value value
 230                             :state (if valuep :stable :pending)
 231                             :generation (if function nil *generation*)
 232                             :goodp valuep)))
 233         (cond ((not function) t)
 234               (valuep (pulse-dep dep))
 235               (*pending-deps*
 236                (enqueue dep *pending-deps*))
 237               (t
 238                (let ((*pending-deps* (make-queue)))
 239                  (enqueue dep *pending-deps*)
 240                  (recompute-deps))))
 241           dep))))
 242
 243 (defmacro dep-try (expr &body body)
 244   "Evaluate EXPR.  If it throws dep-bad then evaluate BODY instead."
 245   (let ((block-name (gensym "TRY")))
 246     `(block ,block-name
 247        (catch 'dep-bad
 248          (return-from ,block-name ,expr))
 249        ,@body)))
 250
 251 (defun dep-bad ()
 252   "Call from a value-func: indicates that the dep should marked as bad."
 253   (throw 'dep-bad nil))
 254
 255 (defun delay-recomputing-deps* (thunk)
 256   "The guts of the DELAY-RECOMPUTING-DEPS macro.  Evaluate THUNK without
 257    immediately updating dependencies until THUNK finishes.  Returns the
 258    value(s) of THUNK."
 259   (if *pending-deps*
 260       (funcall thunk)
 261       (let ((*pending-deps* (make-queue)))
 262         (setf *generation* (list '*generation*))
 263         (multiple-value-prog1
 264             (funcall thunk)
 265           (recompute-deps)))))
 266
 267 (defmacro delay-recomputing-deps (&body body)
 268   "Evaluate BODY, but delay recomputing any deps until the BODY completes
 269    execution.
 270
 271    Note that deps can report incorrect values while delayed recomputation is
 272    in effect.  In the current implementation, the direct dependents of a leaf
 273    dep whose value has changed will be correctly marked as pending (and
 274    recomputed as necessary); higher-level dependents won't be noticed until
 275    the direct dependents are recomputed.
 276
 277    It can be used to apply a number of updates simultaneously to the system.
 278    This is useful for two reasons:
 279
 280      * Firstly, it avoids the computational overheads of propagating changes
 281        repeatedly, so it can be used as a simple optimization.
 282
 283      * Secondly, and perhaps more interestingly, it allows the values of
 284        mutually-dependent deps to be set simultaneously, even though the
 285        values being set may not be compatible with the deps' value
 286        functions."
 287   `(delay-recomputing-deps* #'(lambda () ,@body)))
 288
 289 (defun install-dep-syntax (&optional (readtable *readtable*))
 290   "Installs into the given READTABLE some syntactic shortcuts:
 291
 292    ?FORM -> (dep-value FORM)
 293         Extract (or modify, for a leaf dep) the value of the dep indicated by
 294         FORM.
 295
 296    #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
 297         Return a derived dep whose value function computes the given FORMs
 298         (as an implicit PROGN)
 299
 300    Returns the READTABLE."
 301   (set-macro-character #\?
 302                        (lambda (stream char)
 303                          (declare (ignore char))
 304                          (list 'dep-value (read stream t nil t)))
 305                        readtable)
 306   (set-syntax-from-char #\] #\) readtable readtable)
 307   (set-dispatch-macro-character #\# #\[
 308                                 (lambda (stream arg char)
 309                                   (declare (ignore arg char))
 310                                   `(make-dep :function
 311                                              (lambda ()
 312                                                ,@(read-delimited-list #\]
 313                                                                       stream
 314                                                                       t))))
 315                                 readtable)
 316   readtable)
 317
 318 (defmethod print-object ((dep dep) stream)
 319   (print-unreadable-object (dep stream :type t :identity t)
 320     (cond ((not (eq (dep-state dep) :stable))
 321            (format stream "~S" (dep-state dep)))
 322           ((dep-goodp dep)
 323            (format stream "~S ~W" :good (dep-%value dep)))
 324           (t
 325            (format stream "~S" :bad)))))
 326
 327 #+ test
 328 (progn
 329   (defparameter x (make-leaf-dep 1))
 330   (defparameter y (make-leaf-dep 2))
 331   (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
 332   (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
 333   (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
 334   (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
 335   (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
 336
 337 ;;;----- That's all, folks --------------------------------------------------