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