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 #:weak))
  26 (in-package #:dep)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Constants.
  30
  31 (defconstant +value+ 1
  32   "Flag: dep's value is up-to-date.")
  33 (defconstant +deps+ 2
  34   "Flag: dep is known as a dependent on its dependencies.")
  35 (defconstant +changed+ 4
  36   "Flag: dep has changed in the current recomputation phase.")
  37 (defconstant +recomputing+ 8
  38   "Flag: dep is currently being recomputed.")
  39 (defconstant +queued+ 16
  40   "Flag: dep is currently on the queue for recomputation.")
  41
  42 (defconstant .bad. '.bad.
  43   "Magical value used to indicate bad deps.")
  44
  45 ;;;--------------------------------------------------------------------------
  46 ;;; Global and special variables.
  47
  48 (defvar *generation* (list '*generation*)
  49   "Generation marker, used to remember when we last updated a particular dep.
  50    Essentially, if the dep's generation matches *GENERATION* then it doesn't
  51    need updating again.")
  52
  53 (defvar *evaluating-dep* nil
  54   "The dep currently being evaluated.  This is bound only during the call of
  55    a value-function, and is used to track the dependencies implied during the
  56    function's evaluation.")
  57
  58 (defvar *state* :ready
  59   "The current state.  It may be any of:
  60
  61      * :READY -- the usual state: everything is up-to-date and correct.
  62
  63      * :FROZEN -- the state used to evaluate the body of WITH-DEPS-FROZEN.
  64        Deps may be assigned values, but their dependents are not immediately
  65        recomputed.
  66
  67      * :RECOMPUTING -- the state imposed while updating dependents.")
  68
  69 (defvar *delayed-operations* nil
  70   "A queue of operations delayed by WITH-DEPS-FROZEN.  Only available in the
  71    :RECOMPUTING state.")
  72
  73 (defvar *pending-deps* nil
  74   "A queue of deps pending recomputation.  This is bound to a queue during
  75    recomputation and restored afterwards, so it can also be used as a flag to
  76    detect whether recomputation is happening.
  77
  78    Deps on the queue are always in the current generation, and have the
  79    +QUEUED+ flag set.")
  80
  81 ;;;--------------------------------------------------------------------------
  82 ;;; Data structures.
  83
  84 (export '(dep depp dep-name))
  85 (defstruct (dep (:predicate depp)
  86                 (:constructor %make-dep))
  87   "There are two kinds of `dep', though we use the same object type for both.
  88    A leaf dep has no dependencies, and its value is set explicitly by the
  89    programmer.  A non-leaf dep has a value /function/, which computes the
  90    dep's value as a function of other deps' values.  The dependencies don't
  91    need to be declared in advance, or remain constant over time.
  92
  93    When not during a recomputation phase (i.e., when `stable'), a dep is
  94    either `good' (i.e., it has a value) or `bad'.  An attempt to read the
  95    value of a bad dep results in a throw of `bad-dep'.  Badness propagates
  96    automatically during recomputation phases."
  97   (%value .bad. :type t)
  98   (name nil :type t :read-only t)
  99   (value-function nil :type (or function null) :read-only t)
 100   (value-predicate #'eql :type function :read-only t)
 101   (%flags 0 :type (unsigned-byte 8))
 102   (generation *generation* :type list)
 103   (listeners nil :type list)
 104   (dependents nil :type list)
 105   (dependencies nil :type list)
 106   (weak-pointer nil :type t))
 107
 108 ;;;--------------------------------------------------------------------------
 109 ;;; Main code.
 110
 111 (declaim (inline dep-flags))
 112 (defun dep-flags (dep)
 113   "Return the current flags of DEP.
 114
 115    The flags are fetched from the object if we're in a recomputation phase
 116    and the object's generation is current.  Otherwise the object's flags are
 117    out of date, and we make up a better set."
 118   (cond ((eq *state* :ready) (logior +value+ +deps+))
 119         ((eq (dep-generation dep) *generation*) (dep-%flags dep))
 120         ((not (dep-value-function dep)) (logior +value+ +deps+))
 121         (t 0)))
 122
 123 (declaim (inline (setf dep-flags)))
 124 (defun (setf dep-flags) (flags dep)
 125   "Set the DEP's flags.
 126
 127    This doesn't do anything else like force DEP's generation."
 128   (setf (dep-%flags dep) flags))
 129
 130 (defun update-dep (dep value)
 131   "Modify the value of DEP.
 132
 133    If DEP's value is now different (according to its badness or
 134    value-predicate) then return true; otherwise return false."
 135   (let ((old-value (dep-%value dep)))
 136     (if (if (eq value .bad.)
 137             (eq old-value .bad.)
 138             (and (not (eq old-value .bad.))
 139                  (funcall (dep-value-predicate dep) value old-value)))
 140         nil
 141         (progn (setf (dep-%value dep) value) t))))
 142
 143 (defun new-dep-value (dep)
 144   "Recompute and return the value of DEP, or .BAD. if the dep is bad.
 145
 146    This function is very minimal.  The caller expected to deal with many
 147    aspects of caring for and feeding DEP.  In particular:
 148
 149      * Non-local exits (except throwing DEP-BAD) are not handled here.
 150
 151      * We assume that DEP is already in the current generation, and has its
 152        +RECOMPUTING+ flag set.
 153
 154      * The caller is responsible for setting the current flags afterwards."
 155   (catch 'dep-bad
 156     (let ((*evaluating-dep* dep))
 157       (setf (dep-dependencies dep) nil)
 158       (funcall (dep-value-function dep)))))
 159
 160 (defun propagate-to-dependents (dep)
 161   "Notify the dependents of DEP of a change to its value.
 162
 163    We assume that DEP is up-to-date in the current generation, and has
 164    correct flags (at least +VALUE+ and +CHANGED+, and maybe +DEPS+).
 165    Dependents of DEP are enqueued for recomputation.  The DEP's dependents
 166    are forced into the current generation and enqueued, and the dependents
 167    list is cleared ready to be repopulated.  The DEP's listener functions are
 168    invoked."
 169   (dolist (dweak (dep-dependents dep))
 170     (let ((d (weak-pointer-value dweak)))
 171       (when d
 172         (let ((flags (dep-flags d)))
 173           (unless (plusp (logand flags (logior +queued+ +deps+)))
 174             (enqueue d *pending-deps*)
 175             (setf (dep-generation d) *generation*
 176                   (dep-flags d) (logior (logand flags +value+)
 177                                         +queued+)))))))
 178   (setf (dep-dependents dep) nil)
 179   (dolist (listener (dep-listeners dep))
 180     (funcall listener)))
 181
 182 (defun recompute-dep-value (dep)
 183   "Recompute the value of DEP.
 184
 185    Returns true if DEP's value actually changed, or nil otherwise.  On exit,
 186    the DEP's +VALUE+ and +DEPS+ flags are set, and +CHANGED+ is set if the
 187    value actually changed.
 188
 189    We assume that DEP's dependencies are up-to-date already, and that DEP's
 190    +RECOMPUTING+ flag is set.  In the former case, DEP's dependents and
 191    listeners are notified, using PROPAGATE-TO-DEPENDENTS."
 192   (let ((winning nil) (queued (logand (dep-%flags dep) +queued+)))
 193     (flet ((update (value)
 194              (cond ((update-dep dep value)
 195                     (setf (dep-flags dep) (logior +value+ +deps+ +changed+
 196                                                   queued))
 197                     (propagate-to-dependents dep)
 198                     t)
 199                    (t
 200                     (setf (dep-flags dep) (logior +value+ +deps+ queued))
 201                     nil))))
 202       (unwind-protect
 203            (prog1 (update (new-dep-value dep)) (setf winning t))
 204         (unless winning (update .bad.))))))
 205
 206 (defun force-dep-value (dep)
 207   "Arrange for DEP to have a current value.
 208
 209    Returns true if the DEP's value has changed in this recomputation phase,
 210    or nil if not.
 211
 212    If DEP is already has a good value, then we just use that; the return
 213    value is determined by the +CHANGED+ flag.  Otherwise, we set
 214    +RECOMPUTING+ (in order to trap circularities) and force the values of
 215    DEP's dependencies in turn.  If any of them returned true then we have to
 216    explicitly recompute DEP (so we do); otherwise we can leave it as it is."
 217   (let ((flags (dep-flags dep)))
 218     (cond ((plusp (logand flags +recomputing+))
 219            (error "Ouch!  Circular dependency detected."))
 220           ((plusp (logand flags +value+))
 221            (plusp (logand flags +changed+)))
 222           (t
 223            (setf (dep-generation dep) *generation*
 224                  (dep-flags dep) (logior (logand flags +queued+)
 225                                          +recomputing+))
 226            (if (some #'force-dep-value (dep-dependencies dep))
 227                (recompute-dep-value dep)
 228                (progn (setf (dep-flags dep) flags) nil))))))
 229
 230 (defun %dep-value (dep)
 231   "Do the difficult work of retrieving the current value of a DEP.
 232
 233    This is the unhappy path of `dep-value'."
 234   (force-dep-value dep)
 235   (when *evaluating-dep*
 236     (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
 237     (pushnew dep (dep-dependencies *evaluating-dep*))))
 238
 239 (export 'dep-value)
 240 (declaim (inline dep-value))
 241 (defun dep-value (dep)
 242   "Retrieve the current value from DEP."
 243   (when (eq *state* :recomputing)
 244     (%dep-value dep))
 245   (let ((value (dep-%value dep)))
 246     (if (eq value .bad.)
 247         (throw 'dep-bad .bad.)
 248         value)))
 249
 250 (export 'dep-goodp)
 251 (defun dep-goodp (dep)
 252   "Answer whether DEP is good."
 253   (when (eq *state* :recomputing)
 254     (force-dep-value dep))
 255   (not (eq (dep-%value dep) .bad.)))
 256
 257 (export 'dep-try)
 258 (defmacro dep-try (expr &body body)
 259   "Evaluate EXPR.  If it throws DEP-BAD then evaluate BODY instead."
 260   (let ((block-name (gensym "TRY")))
 261     `(block ,block-name
 262        (catch 'dep-bad
 263          (return-from ,block-name ,expr))
 264        ,@body)))
 265
 266 (export 'dep-bad)
 267 (defun dep-bad ()
 268   "Call from a value-function: indicates that the dep should marked as bad."
 269   (throw 'dep-bad nil))
 270
 271 (defun recompute-pending-deps ()
 272   "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
 273
 274    We bind *STATE* to :RECOMPUTING during the process."
 275   (let ((*state* :recomputing))
 276     (unwind-protect
 277          (loop (when (queue-emptyp *pending-deps*)
 278                  (return))
 279                (let* ((dep (dequeue *pending-deps*))
 280                       (flags (dep-%flags dep)))
 281                  (setf (dep-%flags dep) (logandc2 flags +queued+))
 282                  (cond ((zerop (logand flags +value+))
 283                         (recompute-dep-value dep))
 284                        ((zerop (logand flags +deps+))
 285                         (new-dep-value dep)
 286                         (setf (dep-%flags dep) (logior flags +deps+))))))
 287       (loop (when (queue-emptyp *pending-deps*)
 288               (return))
 289             (let ((d (dequeue *pending-deps*)))
 290               (setf (dep-%value d) .bad.))))))
 291
 292 (defun with-deps-frozen* (thunk &key delay)
 293   "Invoke THUNK in the :FROZEN state.  See WITH-DEPS-FROZEN for full
 294    information."
 295   (ecase *state*
 296     (:frozen
 297      (funcall thunk))
 298     (:recomputing
 299      (unless delay
 300        (error "This really isn't a good time."))
 301      (enqueue thunk *delayed-operations*))
 302     (:ready
 303      (let ((*state* :frozen)
 304            (*delayed-operations* (make-queue))
 305            (*pending-deps* (make-queue)))
 306        (setf *generation* (list '*generation*))
 307        (multiple-value-prog1 (funcall thunk)
 308          (loop (recompute-pending-deps)
 309                (when (queue-emptyp *delayed-operations*)
 310                  (return))
 311                (funcall (dequeue *delayed-operations*))))))))
 312
 313 (export 'with-deps-frozen)
 314 (defmacro with-deps-frozen ((&key delay) &body body)
 315   "Evaluate BODY in the :FROZEN state.
 316
 317    In the :FROZEN state, recomutation is deferred.  If the current state is
 318    :READY, then we enter :FROZEN, evaluate the BODY, and then enter
 319    :RECOMPUTING to fix up the dependency graph.  If the current state is
 320    :FROZEN, we do nothing particularly special.  Finally, if the current
 321    state is :RECOMPUTING then the behaviour depends on the value of
 322    the :DELAY argument: if false, an error is signalled; if true, the
 323    evaluation is postponed until the end of the recomputation.
 324
 325    This macro has four immediate uses.
 326
 327      * Firstly, it's actually the only way to trigger recomputation at all.
 328        It's invoked behind the scenes to do the right thing.
 329
 330      * If you're making a large number of updates without data dependencies
 331        then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
 332        and only having a single recomputation phase.
 333
 334      * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
 335        You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
 336        assignment until later.  Deferred operations take place in the order
 337        in which they were requested.
 338
 339      * Finally, you can use it to force a number of deps to hold given values
 340        simultaneously, despite their value-functions disagreeing."
 341   `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
 342
 343 (defun (setf dep-value) (value dep)
 344   "Assign the VALUE to the DEP, forcing recomputation if necessary."
 345   (with-deps-frozen ()
 346     (when (update-dep dep value)
 347       (setf (dep-generation dep) *generation*
 348             (dep-flags dep) (logior +value+ +changed+))
 349       (propagate-to-dependents dep)))
 350   value)
 351
 352 (export 'dep-make-bad)
 353 (defun dep-make-bad (dep)
 354   "Mark DEP as being bad."
 355   (setf (dep-value dep) .bad.))
 356
 357 (export 'dep-add-listener)
 358 (defun dep-add-listener (dep func)
 359   "Add a listener function FUNC to the DEP.  The FUNC is called each time the
 360    DEP's value (or good/bad state) changes.  It is called with no arguments,
 361    and its return value is ignored."
 362   (push func (dep-listeners dep)))
 363
 364 (export 'make-dep)
 365 (defun make-dep (&rest args)
 366   "Create a new DEP object.  There are two basic argument forms:
 367
 368    (:value &optional OBJECT)
 369         Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
 370         dep is initially bad.  The keyword :LEAF is accepted as a synonym.
 371
 372    (:function FUNCTION)
 373         Return a non-leaf dep whose value is computed by FUNCTION.
 374
 375    Additionally, if the first argument is something other than :VALUE or
 376    :FUNCTION (ideally not a keyword, for forward compatibility), then the
 377    first argument is inspected: if it's a function, then a function dep is
 378    retuerned (as if you'd specified :function); otherwise a leaf dep is
 379    returned.
 380
 381    Finally, it's possible to specify both :VALUE and :FUNCTION
 382    simultaneously; this will set the initial values as requested, but
 383    recompute them as necessary.  It is possible to establish dependency
 384    cycles, but you need to suppress recomputation in order to do this
 385    correctly -- see the DELAY-RECOMPUTING-DEPS macro.
 386
 387    If no arguments are given, a bad leaf dep is returned."
 388
 389   (flet ((arg () (if args (pop args)
 390                      (error "Not enough arguments to MAKE-DEP."))))
 391
 392     ;; Sort out the arguments.
 393     (let ((value .bad.)
 394           (valuep nil)
 395           (name nil)
 396           (predicate #'eql)
 397           (listeners nil)
 398           (function nil))
 399       (do () ((endp args))
 400         (let ((indicator (pop args)))
 401           (case indicator
 402             ((:value :leaf)
 403              (setf value (if args (pop args) .bad.)
 404                    valuep t))
 405             (:function
 406              (setf function (arg)))
 407             (:predicate
 408              (setf predicate (arg)))
 409             (:name
 410              (setf name (arg)))
 411             (:listener
 412              (push (arg) listeners))
 413             (t
 414              (cond ((functionp indicator)
 415                     (setf function indicator))
 416                    (t
 417                     (setf value indicator
 418                           valuep t)))))))
 419       (unless (or valuep function)
 420         (setf valuep t))
 421
 422       ;; Create the object appropriately.
 423       (let ((dep (%make-dep :value-function function
 424                             :%value value
 425                             :name name
 426                             :listeners listeners
 427                             :%flags (logior (if valuep +value+ 0)
 428                                             (if function +queued+ +deps+)
 429                                             +changed+)
 430                             :value-predicate predicate
 431                             :generation *generation*)))
 432         (setf (dep-weak-pointer dep) (make-weak-pointer dep))
 433         (when function
 434           (with-deps-frozen ()
 435             (enqueue dep *pending-deps*)))
 436         dep))))
 437
 438 (export 'install-dep-syntax)
 439 (defun install-dep-syntax (&optional (readtable *readtable*))
 440   "Installs into the given READTABLE some syntactic shortcuts:
 441
 442    ?FORM -> (dep-value FORM)
 443         Extract (or modify, for a leaf dep) the value of the dep indicated by
 444         FORM.
 445
 446    #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
 447         Return a derived dep whose value function computes the given FORMs
 448         (as an implicit PROGN)
 449
 450    Returns the READTABLE."
 451   (set-macro-character #\?
 452                        (lambda (stream char)
 453                          (declare (ignore char))
 454                          (list 'dep-value (read stream t nil t)))
 455                        readtable)
 456   (set-syntax-from-char #\] #\) readtable readtable)
 457   (set-dispatch-macro-character #\# #\[
 458                                 (lambda (stream arg char)
 459                                   (declare (ignore arg char))
 460                                   `(make-dep :function
 461                                              (lambda ()
 462                                                ,@(read-delimited-list #\]
 463                                                                       stream
 464                                                                       t))))
 465                                 readtable)
 466   readtable)
 467
 468 #- abcl
 469 (defmethod print-object ((dep dep) stream)
 470   (print-unreadable-object (dep stream :type t :identity t)
 471     (pprint-logical-block (stream nil)
 472       (let ((flags (dep-flags dep))
 473             (value (dep-%value dep)))
 474         (cond ((zerop (logand flags +value+))
 475                (write-string "#<out-of-date>" stream))
 476               ((eq value .bad.)
 477                (write-string "#<bad>" stream))
 478               (t
 479                (write value :stream stream)))
 480         (when (dep-name dep)
 481           (format stream " ~_~S ~@_~W" :name (dep-name dep)))
 482         (when (zerop (logand flags +deps+))
 483           (format stream " ~_~S" :recompute-deps))
 484         (when (plusp (logand flags +queued+))
 485           (format stream " ~_~S" :queued))
 486         (when (plusp (logand flags +changed+))
 487           (format stream " ~_~S" :changed))))))
 488
 489 ;;;--------------------------------------------------------------------------
 490 ;;; Tests.
 491
 492 #+ test
 493 (progn
 494   (defparameter x (make-dep :name 'x 1))
 495   (defparameter y (make-dep :name 'y 2))
 496   (defparameter z (make-dep :name 'z
 497                             (lambda () (+ (dep-value x) (dep-value y)))))
 498   (defparameter w (make-dep :name 'w
 499                             (lambda () (* (dep-value x) (dep-value z)))))
 500   (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
 501   (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
 502   (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
 503
 504 #+ test
 505 (progn
 506   (defparameter a (make-dep :name 'a 1))
 507   (defparameter b (make-dep :name 'b 2))
 508   (defparameter c (make-dep :name 'c
 509                             (lambda () (1+ (dep-value a)))))
 510   (defparameter d (make-dep :name 'd
 511                             (lambda () (* (dep-value c) (dep-value b)))))
 512   (defparameter e (make-dep :name 'e
 513                             (lambda () (- (dep-value d) (dep-value a)))))
 514   ;;  a   b   c = a + 1   d = c*b   e = d - a
 515   ;;  1   2      2           4          3
 516   ;;  4   2      5          10          6
 517   (values (dep-value e)
 518           (progn
 519             (setf (dep-value a) 4)
 520             (dep-value e))))
 521
 522 #+ test
 523 (progn
 524   (defparameter x nil)
 525   (defparameter y nil)
 526   (with-deps-frozen ()
 527     (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
 528           y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
 529
 530 #+ test
 531 (trace with-deps-frozen* update-dep new-dep-value force-dep-value
 532        recompute-dep-value recompute-pending-deps propagate-to-dependents
 533        dep-value)
 534
 535 ;;;----- That's all, folks --------------------------------------------------