chiark - git - mdw - jlisp/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 #:make-leaf-dep #:dep-goodp
  27            #:dep-value #:dep-make-bad #:dep-bad #:dep-try
  28            #:dep-add-listener))
  29 (in-package #:dep)
  30
  31 ;;;--------------------------------------------------------------------------
  32 ;;; Dependencies.
  33
  34 (defstruct (dep (:predicate depp)
  35                 (:constructor %make-dep))
  36   "There are two kinds of `dep', though we use the same object type for both.
  37    A leaf dep has no dependencies, and its value is set explicitly by the
  38    programmer.  A non-leaf dep has a value /function/, which computes the
  39    dep's value as a function of other deps' values.  The dependencies don't
  40    need to be declared in advance, or remain constant over time.
  41
  42    When not during a recomputation phase (i.e., when `stable'), a dep is
  43    either `good' (i.e., it has a value) or `bad'.  An attempt to read the
  44    value of a bad dep results in a throw of `bad-dep'.  Badness propagates
  45    automatically during recomputation phases."
  46   (%value nil :type t)
  47   (value-func nil :type (or function null))
  48   (value-predicate #'eql :type function)
  49   (goodp nil :type boolean)
  50   (state :pending :type (member :stable :pending :recomputing))
  51   (listeners nil :type list)
  52   (dependents nil :type list))
  53
  54 (defvar *evaluating-dep* nil
  55   "The dep currently being evaluated.  This is bound only during the call of
  56    a value-func, and is used to track the dependencies implied during the
  57    function's evaluation.")
  58
  59 (defvar *pending-deps* nil
  60   "A queue of deps pending recomputation.  This is bound to a queue during
  61    recomputation and restored afterwards, so it can also be used as a flag to
  62    detect whether recomputation is happening.")
  63
  64 (defun kick-dep (dep)
  65   "Call when DEP's value (or good/bad state) has changed.  Marks the
  66    dependents of DEP as :pending, if they're currently :stable, and then
  67    clears the dependent list.  Also invokes DEP's listener functions."
  68   (dolist (d (dep-dependents dep))
  69     (when (eq (dep-state d) :stable)
  70       (enqueue d *pending-deps*)
  71       (setf (dep-state d) :pending)))
  72   (setf (dep-dependents dep) nil)
  73   (dolist (l (dep-listeners dep))
  74     (funcall l)))
  75
  76 (defun update-dep (dep value &optional (goodp t))
  77   "Modify the value of DEP.  If GOODP is t, then mark it as good and store
  78    VALUE is its new value; otherwise mark it bad.  If DEP's value is now
  79    different (according to its value-predicate) then return true; otherwise
  80    return false."
  81   (setf (dep-state dep) :stable)
  82   (cond ((not goodp)
  83          (if (dep-goodp dep)
  84              (progn (setf (dep-goodp dep) nil) t)
  85              nil))
  86         ((and (dep-goodp dep)
  87               (funcall (dep-value-predicate dep) value (dep-%value dep)))
  88          nil)
  89         (t
  90          (setf (dep-goodp dep) t
  91                (dep-%value dep) value)
  92          t)))
  93
  94 (defun recompute-dep (dep)
  95   "Recompute the value of DEP.  This function is careful to trap nonlocal
  96    transfers from the value-func."
  97   (let ((winning nil))
  98     (unwind-protect
  99          (catch 'dep-bad
 100            (setf (dep-state dep) :recomputing)
 101            (when (update-dep dep (let ((*evaluating-dep* dep))
 102                                    (funcall (dep-value-func dep))))
 103              (kick-dep dep))
 104            (setf winning t))
 105       (unless winning
 106         (when (update-dep dep nil nil)
 107           (kick-dep dep))))))
 108
 109 (defun recompute-deps ()
 110   "Recompute all the pending deps, and any others that depend on them."
 111   (unwind-protect
 112        (loop (when (queue-emptyp *pending-deps*)
 113                (return))
 114              (let ((dep (dequeue *pending-deps*)))
 115                (when (eq (dep-state dep) :pending)
 116                  (recompute-dep dep))))
 117     (loop (when (queue-emptyp *pending-deps*)
 118             (return))
 119           (let ((d (dequeue *pending-deps*)))
 120             (setf (dep-state d) :stable
 121                   (dep-goodp d) nil)))))
 122
 123 (defun ensure-dep-has-value (dep)
 124   "Ensure that DEP has a stable value.  If DEP is currently computing,
 125    signals an error."
 126   (ecase (dep-state dep)
 127     (:stable)
 128     (:pending
 129      (recompute-dep dep))
 130     (:recomputing
 131      (error "Ouch!  Cyclic dependency."))))
 132
 133 (defun pulse-dep (dep)
 134   "Notifies DEP of a change in its value.  If a recomputation phase is
 135    currently under way, queue the dependents and leave fixing things up to
 136    the outer loop; otherwise start up a recomputation phase."
 137   (if *pending-deps*
 138       (kick-dep dep)
 139       (let ((*pending-deps* (make-queue)))
 140         (kick-dep dep)
 141         (recompute-deps))))
 142
 143 (defun (setf dep-value) (value dep)
 144   "Set DEP's value to be VALUE (and mark it as being good)."
 145   (when (dep-value-func dep)
 146     (error "Not a leaf dep."))
 147   (when (update-dep dep value)
 148     (pulse-dep dep))
 149   value)
 150
 151 (defun dep-make-bad (dep)
 152   "Mark DEP as being bad."
 153   (when (dep-value-func dep)
 154     (error "Not a leaf dep."))
 155   (when (update-dep dep nil nil)
 156     (pulse-dep dep)))
 157
 158 (defun dep-add-listener (dep func)
 159   "Add a listener function FUNC to the DEP.  The FUNC is called each time the
 160    DEP's value (or good/bad state) changes.  It is called with no arguments,
 161    and its return value is ignored."
 162   (push func (dep-listeners dep)))
 163
 164 (defun dep-value (dep)
 165   "Retrieve the current value from DEP."
 166   (when *evaluating-dep*
 167     (pushnew *evaluating-dep* (dep-dependents dep)))
 168   (ensure-dep-has-value dep)
 169   (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil)))
 170
 171 (defun make-dep (value-func)
 172   "Create a new DEP with the given VALUE-FUNC."
 173   (let ((dep (%make-dep :value-func value-func)))
 174     (let ((*pending-deps* (make-queue)))
 175       (enqueue dep *pending-deps*)
 176       (recompute-deps))
 177     dep))
 178
 179 (defun make-leaf-dep (&optional (value nil goodp))
 180   "Creates a new DEP with the given VALUE, if any."
 181   (%make-dep :%value value :goodp goodp :state :stable))
 182
 183 (defmacro dep-try (expr &body body)
 184   "Evaluate EXPR.  If it throws dep-bad then evaluate BODY instead."
 185   (let ((block-name (gensym "TRY")))
 186     `(block ,block-name
 187        (catch 'dep-bad
 188          (return-from ,block-name ,expr))
 189        ,@body)))
 190
 191 (defun dep-bad ()
 192   "Call from a value-func: indicates that the dep should marked as bad."
 193   (throw 'dep-bad nil))
 194
 195 #+ no
 196 (defmethod print-object ((dep dep) stream)
 197   (print-unreadable-object (dep stream :type t :identity t)
 198     (ensure-dep-has-value dep)
 199     (if (dep-goodp dep)
 200         (format stream ":GOOD ~W" (dep-%value dep))
 201         (format stream ":BAD"))))
 202
 203 #+ test
 204 (progn
 205   (defparameter x (make-leaf-dep 1))
 206   (defparameter y (make-leaf-dep 2))
 207   (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
 208   (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
 209   (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
 210   (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
 211   (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
 212
 213 ;;;----- That's all, folks --------------------------------------------------