mdw@git.distorted.org.uk Git - 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   (when *evaluating-dep*
 233     (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
 234     (pushnew dep (dep-dependencies *evaluating-dep*)))
 235   (force-dep-value dep))
 236
 237 (export 'dep-value)
 238 (declaim (inline dep-value))
 239 (defun dep-value (dep)
 240   "Retrieve the current value from DEP."
 241   (when (eq *state* :recomputing)
 242     (%dep-value dep))
 243   (let ((value (dep-%value dep)))
 244     (if (eq value .bad.)
 245         (throw 'dep-bad .bad.)
 246         value)))
 247
 248 (export 'dep-goodp)
 249 (defun dep-goodp (dep)
 250   "Answer whether DEP is good."
 251   (when (eq *state* :recomputing)
 252     (force-dep-value dep))
 253   (not (eq (dep-%value dep) .bad.)))
 254
 255 (export 'dep-try)
 256 (defmacro dep-try (expr &body body)
 257   "Evaluate EXPR.  If it throws DEP-BAD then evaluate BODY instead."
 258   (let ((block-name (gensym "TRY")))
 259     `(block ,block-name
 260        (catch 'dep-bad
 261          (return-from ,block-name ,expr))
 262        ,@body)))
 263
 264 (export 'dep-bad)
 265 (defun dep-bad ()
 266   "Call from a value-function: indicates that the dep should marked as bad."
 267   (throw 'dep-bad nil))
 268
 269 (defun recompute-pending-deps ()
 270   "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
 271
 272    We bind *STATE* to :RECOMPUTING during the process."
 273   (let ((*state* :recomputing))
 274     (unwind-protect
 275          (loop (when (queue-emptyp *pending-deps*)
 276                  (return))
 277                (let* ((dep (dequeue *pending-deps*))
 278                       (flags (dep-%flags dep)))
 279                  (setf (dep-%flags dep) (logandc2 flags +queued+))
 280                  (cond ((zerop (logand flags +value+))
 281                         (recompute-dep-value dep))
 282                        ((zerop (logand flags +deps+))
 283                         (new-dep-value dep)
 284                         (setf (dep-%flags dep) (logior flags +deps+))))))
 285       (loop (when (queue-emptyp *pending-deps*)
 286               (return))
 287             (let ((d (dequeue *pending-deps*)))
 288               (setf (dep-%value d) .bad.))))))
 289
 290 (defun with-deps-frozen* (thunk &key delay)
 291   "Invoke THUNK in the :FROZEN state.  See WITH-DEPS-FROZEN for full
 292    information."
 293   (ecase *state*
 294     (:frozen
 295      (funcall thunk))
 296     (:recomputing
 297      (unless delay
 298        (error "This really isn't a good time."))
 299      (enqueue thunk *delayed-operations*))
 300     (:ready
 301      (let ((*state* :frozen)
 302            (*delayed-operations* (make-queue))
 303            (*pending-deps* (make-queue)))
 304        (setf *generation* (list '*generation*))
 305        (multiple-value-prog1 (funcall thunk)
 306          (loop (recompute-pending-deps)
 307                (when (queue-emptyp *delayed-operations*)
 308                  (return))
 309                (funcall (dequeue *delayed-operations*))))))))
 310
 311 (export 'with-deps-frozen)
 312 (defmacro with-deps-frozen ((&key delay) &body body)
 313   "Evaluate BODY in the :FROZEN state.
 314
 315    In the :FROZEN state, recomutation is deferred.  If the current state is
 316    :READY, then we enter :FROZEN, evaluate the BODY, and then enter
 317    :RECOMPUTING to fix up the dependency graph.  If the current state is
 318    :FROZEN, we do nothing particularly special.  Finally, if the current
 319    state is :RECOMPUTING then the behaviour depends on the value of
 320    the :DELAY argument: if false, an error is signalled; if true, the
 321    evaluation is postponed until the end of the recomputation.
 322
 323    This macro has four immediate uses.
 324
 325      * Firstly, it's actually the only way to trigger recomputation at all.
 326        It's invoked behind the scenes to do the right thing.
 327
 328      * If you're making a large number of updates without data dependencies
 329        then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
 330        and only having a single recomputation phase.
 331
 332      * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
 333        You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
 334        assignment until later.  Deferred operations take place in the order
 335        in which they were requested.
 336
 337      * Finally, you can use it to force a number of deps to hold given values
 338        simultaneously, despite their value-functions disagreeing."
 339   `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
 340
 341 (defun (setf dep-value) (value dep)
 342   "Assign the VALUE to the DEP, forcing recomputation if necessary."
 343   (with-deps-frozen ()
 344     (when (update-dep dep value)
 345       (setf (dep-generation dep) *generation*
 346             (dep-flags dep) (logior +value+ +changed+))
 347       (propagate-to-dependents dep)))
 348   value)
 349
 350 (export 'dep-make-bad)
 351 (defun dep-make-bad (dep)
 352   "Mark DEP as being bad."
 353   (setf (dep-value dep) .bad.))
 354
 355 (export 'dep-add-listener)
 356 (defun dep-add-listener (dep func)
 357   "Add a listener function FUNC to the DEP.  The FUNC is called each time the
 358    DEP's value (or good/bad state) changes.  It is called with no arguments,
 359    and its return value is ignored."
 360   (push func (dep-listeners dep)))
 361
 362 (export 'make-dep)
 363 (defun make-dep (&rest args)
 364   "Create a new DEP object.  There are two basic argument forms:
 365
 366    (:value &optional OBJECT)
 367         Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
 368         dep is initially bad.  The keyword :LEAF is accepted as a synonym.
 369
 370    (:function FUNCTION)
 371         Return a non-leaf dep whose value is computed by FUNCTION.
 372
 373    Additionally, if the first argument is something other than :VALUE or
 374    :FUNCTION (ideally not a keyword, for forward compatibility), then the
 375    first argument is inspected: if it's a function, then a function dep is
 376    retuerned (as if you'd specified :function); otherwise a leaf dep is
 377    returned.
 378
 379    Finally, it's possible to specify both :VALUE and :FUNCTION
 380    simultaneously; this will set the initial values as requested, but
 381    recompute them as necessary.  It is possible to establish dependency
 382    cycles, but you need to suppress recomputation in order to do this
 383    correctly -- see the DELAY-RECOMPUTING-DEPS macro.
 384
 385    If no arguments are given, a bad leaf dep is returned."
 386
 387   (flet ((arg () (if args (pop args)
 388                      (error "Not enough arguments to MAKE-DEP."))))
 389
 390     ;; Sort out the arguments.
 391     (let ((value .bad.)
 392           (valuep nil)
 393           (name nil)
 394           (predicate #'eql)
 395           (listeners nil)
 396           (function nil))
 397       (do () ((endp args))
 398         (let ((indicator (pop args)))
 399           (case indicator
 400             ((:value :leaf)
 401              (setf value (if args (pop args) .bad.)
 402                    valuep t))
 403             (:function
 404              (setf function (arg)))
 405             (:predicate
 406              (setf predicate (arg)))
 407             (:name
 408              (setf name (arg)))
 409             (:listener
 410              (push (arg) listeners))
 411             (t
 412              (cond ((functionp indicator)
 413                     (setf function indicator))
 414                    (t
 415                     (setf value indicator
 416                           valuep t)))))))
 417       (unless (or valuep function)
 418         (setf valuep t))
 419
 420       ;; Create the object appropriately.
 421       (let ((dep (%make-dep :value-function function
 422                             :%value value
 423                             :name name
 424                             :listeners listeners
 425                             :%flags (logior (if valuep +value+ 0)
 426                                             (if function +queued+ +deps+)
 427                                             +changed+)
 428                             :value-predicate predicate
 429                             :generation *generation*)))
 430         (setf (dep-weak-pointer dep) (make-weak-pointer dep))
 431         (when function
 432           (with-deps-frozen ()
 433             (enqueue dep *pending-deps*)))
 434         dep))))
 435
 436 (export 'install-dep-syntax)
 437 (defun install-dep-syntax (&optional (readtable *readtable*))
 438   "Installs into the given READTABLE some syntactic shortcuts:
 439
 440    ?FORM -> (dep-value FORM)
 441         Extract (or modify, for a leaf dep) the value of the dep indicated by
 442         FORM.
 443
 444    #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
 445         Return a derived dep whose value function computes the given FORMs
 446         (as an implicit PROGN)
 447
 448    Returns the READTABLE."
 449   (set-macro-character #\?
 450                        (lambda (stream char)
 451                          (declare (ignore char))
 452                          (list 'dep-value (read stream t nil t)))
 453                        readtable)
 454   (set-syntax-from-char #\] #\) readtable readtable)
 455   (set-dispatch-macro-character #\# #\[
 456                                 (lambda (stream arg char)
 457                                   (declare (ignore arg char))
 458                                   `(make-dep :function
 459                                              (lambda ()
 460                                                ,@(read-delimited-list #\]
 461                                                                       stream
 462                                                                       t))))
 463                                 readtable)
 464   readtable)
 465
 466 #- abcl
 467 (defmethod print-object ((dep dep) stream)
 468   (print-unreadable-object (dep stream :type t :identity t)
 469     (pprint-logical-block (stream nil)
 470       (let ((flags (dep-flags dep))
 471             (value (dep-%value dep)))
 472         (cond ((zerop (logand flags +value+))
 473                (write-string "#<out-of-date>" stream))
 474               ((eq value .bad.)
 475                (write-string "#<bad>" stream))
 476               (t
 477                (write value :stream stream)))
 478         (when (dep-name dep)
 479           (format stream " ~_~S ~@_~W" :name (dep-name dep)))
 480         (when (zerop (logand flags +deps+))
 481           (format stream " ~_~S" :recompute-deps))
 482         (when (plusp (logand flags +queued+))
 483           (format stream " ~_~S" :queued))
 484         (when (plusp (logand flags +changed+))
 485           (format stream " ~_~S" :changed))))))
 486
 487 ;;;--------------------------------------------------------------------------
 488 ;;; Tests.
 489
 490 #+ test
 491 (progn
 492   (defparameter x (make-dep :name 'x 1))
 493   (defparameter y (make-dep :name 'y 2))
 494   (defparameter z (make-dep :name 'z
 495                             (lambda () (+ (dep-value x) (dep-value y)))))
 496   (defparameter w (make-dep :name 'w
 497                             (lambda () (* (dep-value x) (dep-value z)))))
 498   (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
 499   (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
 500   (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
 501
 502 #+ test
 503 (progn
 504   (defparameter a (make-dep :name 'a 1))
 505   (defparameter b (make-dep :name 'b 2))
 506   (defparameter c (make-dep :name 'c
 507                             (lambda () (1+ (dep-value a)))))
 508   (defparameter d (make-dep :name 'd
 509                             (lambda () (* (dep-value c) (dep-value b)))))
 510   (defparameter e (make-dep :name 'e
 511                             (lambda () (- (dep-value d) (dep-value a)))))
 512   ;;  a   b   c = a + 1   d = c*b   e = d - a
 513   ;;  1   2      2           4          3
 514   ;;  4   2      5          10          6
 515   (values (dep-value e)
 516           (progn
 517             (setf (dep-value a) 4)
 518             (dep-value e))))
 519
 520 #+ test
 521 (progn
 522   (defparameter x nil)
 523   (defparameter y nil)
 524   (with-deps-frozen ()
 525     (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
 526           y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
 527
 528 #+ test
 529 (trace with-deps-frozen* update-dep new-dep-value force-dep-value
 530        recompute-dep-value recompute-pending-deps propagate-to-dependents
 531        dep-value)
 532
 533 ;;;----- That's all, folks --------------------------------------------------