(defpackage #:dep
(:use #:common-lisp #:queue #:weak)
- (:export #:dep #:depp #:make-dep #:dep-goodp
- #:delay-recomputing-deps
+ (:export #:dep #:depp #:make-dep #:dep-goodp #:dep-name
+ #:with-deps-frozen
#:install-dep-syntax
#:dep-value #:dep-make-bad #:dep-bad #:dep-try
#:dep-add-listener))
(in-package #:dep)
;;;--------------------------------------------------------------------------
-;;; Dependencies.
+;;; Constants.
+
+(defconstant +value+ 1
+ "Flag: dep's value is up-to-date.")
+(defconstant +deps+ 2
+ "Flag: dep is known as a dependent on its dependencies.")
+(defconstant +changed+ 4
+ "Flag: dep has changed in the current recomputation phase.")
+(defconstant +recomputing+ 8
+ "Flag: dep is currently being recomputed.")
+(defconstant +queued+ 16
+ "Flag: dep is currently on the queue for recomputation.")
+
+(defconstant .bad. '.bad.
+ "Magical value used to indicate bad deps.")
+
+;;;--------------------------------------------------------------------------
+;;; Global and special variables.
(defvar *generation* (list '*generation*)
"Generation marker, used to remember when we last updated a particular dep.
(defvar *evaluating-dep* nil
"The dep currently being evaluated. This is bound only during the call of
- a value-func, and is used to track the dependencies implied during the
+ a value-function, and is used to track the dependencies implied during the
function's evaluation.")
+(defvar *state* :ready
+ "The current state. It may be any of:
+
+ * :READY -- the usual state: everything is up-to-date and correct.
+
+ * :FROZEN -- the state used to evaluate the body of WITH-DEPS-FROZEN.
+ Deps may be assigned values, but their dependents are not immediately
+ recomputed.
+
+ * :RECOMPUTING -- the state imposed while updating dependents.")
+
+(defvar *delayed-operations* nil
+ "A queue of operations delayed by WITH-DEPS-FROZEN. Only available in the
+ :RECOMPUTING state.")
+
(defvar *pending-deps* nil
"A queue of deps pending recomputation. This is bound to a queue during
recomputation and restored afterwards, so it can also be used as a flag to
- detect whether recomputation is happening.")
+ detect whether recomputation is happening.
+
+ Deps on the queue are always in the current generation, and have the
+ +QUEUED+ flag set.")
+
+;;;--------------------------------------------------------------------------
+;;; Data structures.
(defstruct (dep (:predicate depp)
(:constructor %make-dep))
either `good' (i.e., it has a value) or `bad'. An attempt to read the
value of a bad dep results in a throw of `bad-dep'. Badness propagates
automatically during recomputation phases."
- (%value nil :type t)
- (value-func nil :type (or function null))
+ (%value .bad. :type t)
+ (name nil :type t)
+ (value-function nil :type (or function null))
(value-predicate #'eql :type function)
- (goodp nil :type boolean)
- (state :pending :type (member :stable :pending :recomputing))
+ (%flags 0 :type (unsigned-byte 8))
(generation *generation* :type list)
(listeners nil :type list)
(dependents nil :type list)
+ (dependencies nil :type list)
(weak-pointer nil :type t))
-(defun kick-dep (dep)
- "Call when DEP's value (or good/bad state) has changed. Marks the
- dependents of DEP as :pending, if they're currently :stable, and then
- clears the dependent list. Also invokes DEP's listener functions."
- (setf (dep-generation dep) *generation*)
+;;;--------------------------------------------------------------------------
+;;; Main code.
+
+(declaim (inline dep-flags))
+(defun dep-flags (dep)
+ "Return the current flags of DEP.
+
+ The flags are fetched from the object if we're in a recomputation phase
+ and the object's generation is current. Otherwise the object's flags are
+ out of date, and we make up a better set."
+ (cond ((eq *state* :ready) (logior +value+ +deps+))
+ ((eq (dep-generation dep) *generation*) (dep-%flags dep))
+ ((not (dep-value-function dep)) (logior +value+ +deps+))
+ (t 0)))
+
+(declaim (inline (setf dep-flags)))
+(defun (setf dep-flags) (flags dep)
+ "Set the DEP's flags.
+
+ This doesn't do anything else like force DEP's generation."
+ (setf (dep-%flags dep) flags))
+
+(defun update-dep (dep value)
+ "Modify the value of DEP.
+
+ If DEP's value is now different (according to its badness or
+ value-predicate) then return true; otherwise return false."
+ (let ((old-value (dep-%value dep)))
+ (if (if (eq value .bad.)
+ (eq old-value .bad.)
+ (and (not (eq old-value .bad.))
+ (funcall (dep-value-predicate dep) value old-value)))
+ nil
+ (progn (setf (dep-%value dep) value) t))))
+
+(defun new-dep-value (dep)
+ "Recompute and return the value of DEP, or .BAD. if the dep is bad.
+
+ This function is very minimal. The caller expected to deal with many
+ aspects of caring for and feeding DEP. In particular:
+
+ * Non-local exits (except throwing DEP-BAD) are not handled here.
+
+ * We assume that DEP is already in the current generation, and has its
+ +RECOMPUTING+ flag set.
+
+ * The caller is responsible for setting the current flags afterwards."
+ (catch 'dep-bad
+ (let ((*evaluating-dep* dep))
+ (setf (dep-dependencies dep) nil)
+ (funcall (dep-value-function dep)))))
+
+(defun propagate-to-dependents (dep)
+ "Notify the dependents of DEP of a change to its value.
+
+ We assume that DEP is up-to-date in the current generation, and has
+ correct flags (at least +VALUE+ and +CHANGED+, and maybe +DEPS+).
+ Dependents of DEP are enqueued for recomputation. The DEP's dependents
+ are forced into the current generation and enqueued, and the dependents
+ list is cleared ready to be repopulated. The DEP's listener functions are
+ invoked."
(dolist (dweak (dep-dependents dep))
(let ((d (weak-pointer-value dweak)))
- (when (and d (eq (dep-state d) :stable))
- (enqueue d *pending-deps*)
- (setf (dep-state d) :pending))))
+ (when d
+ (let ((flags (dep-flags d)))
+ (unless (plusp (logand flags (logior +queued+ +deps+)))
+ (enqueue d *pending-deps*)
+ (setf (dep-generation d) *generation*
+ (dep-flags d) (logior (logand flags +value+)
+ +queued+)))))))
(setf (dep-dependents dep) nil)
- (dolist (l (dep-listeners dep))
- (funcall l)))
-
-(defun update-dep (dep value &optional (goodp t))
- "Modify the value of DEP. If GOODP is t, then mark it as good and store
- VALUE is its new value; otherwise mark it bad. If DEP's value is now
- different (according to its value-predicate) then return true; otherwise
- return false."
- (setf (dep-state dep) :stable)
- (cond ((not goodp)
- (if (dep-goodp dep)
- (progn (setf (dep-goodp dep) nil) t)
- nil))
- ((and (dep-goodp dep)
- (funcall (dep-value-predicate dep) value (dep-%value dep)))
- nil)
- (t
- (setf (dep-goodp dep) t
- (dep-%value dep) value)
- t)))
-
-(defun recompute-dep (dep)
- "Recompute the value of DEP. This function is careful to trap nonlocal
- transfers from the value-func."
- (unless (eq (dep-generation dep) *generation*)
- (let ((winning nil))
+ (dolist (listener (dep-listeners dep))
+ (funcall listener)))
+
+(defun recompute-dep-value (dep)
+ "Recompute the value of DEP.
+
+ Returns true if DEP's value actually changed, or nil otherwise. On exit,
+ the DEP's +VALUE+ and +DEPS+ flags are set, and +CHANGED+ is set if the
+ value actually changed.
+
+ We assume that DEP's dependencies are up-to-date already, and that DEP's
+ +RECOMPUTING+ flag is set. In the former case, DEP's dependents and
+ listeners are notified, using PROPAGATE-TO-DEPENDENTS."
+ (let ((winning nil) (queued (logand (dep-%flags dep) +queued+)))
+ (flet ((update (value)
+ (cond ((update-dep dep value)
+ (setf (dep-flags dep) (logior +value+ +deps+ +changed+
+ queued))
+ (propagate-to-dependents dep)
+ t)
+ (t
+ (setf (dep-flags dep) (logior +value+ +deps+ queued))
+ nil))))
(unwind-protect
- (catch 'dep-bad
- (setf (dep-state dep) :recomputing)
- (when (update-dep dep (let ((*evaluating-dep*
- (dep-weak-pointer dep)))
- (funcall (dep-value-func dep))))
- (kick-dep dep))
- (setf winning t))
- (unless winning
- (when (update-dep dep nil nil)
- (kick-dep dep)))))))
-
-(defun recompute-deps ()
- "Recompute all the pending deps, and any others that depend on them."
- (unwind-protect
- (loop (when (queue-emptyp *pending-deps*)
- (return))
- (let ((dep (dequeue *pending-deps*)))
- (when (eq (dep-state dep) :pending)
- (recompute-dep dep))))
- (loop (when (queue-emptyp *pending-deps*)
- (return))
- (let ((d (dequeue *pending-deps*)))
- (setf (dep-state d) :stable
- (dep-goodp d) nil)))))
-
-(defun ensure-dep-has-value (dep)
- "Ensure that DEP has a stable value. If DEP is currently computing,
- signals an error."
- (ecase (dep-state dep)
- (:stable)
- (:pending
- (recompute-dep dep))
+ (prog1 (update (new-dep-value dep)) (setf winning t))
+ (unless winning (update .bad.))))))
+
+(defun force-dep-value (dep)
+ "Arrange for DEP to have a current value.
+
+ Returns true if the DEP's value has changed in this recomputation phase,
+ or nil if not.
+
+ If DEP is already has a good value, then we just use that; the return
+ value is determined by the +CHANGED+ flag. Otherwise, we set
+ +RECOMPUTING+ (in order to trap circularities) and force the values of
+ DEP's dependencies in turn. If any of them returned true then we have to
+ explicitly recompute DEP (so we do); otherwise we can leave it as it is."
+ (let ((flags (dep-flags dep)))
+ (cond ((plusp (logand flags +recomputing+))
+ (error "Ouch! Circular dependency detected."))
+ ((plusp (logand flags +value+))
+ (plusp (logand flags +changed+)))
+ (t
+ (setf (dep-generation dep) *generation*
+ (dep-flags dep) (logior (logand flags +queued+)
+ +recomputing+))
+ (if (some #'force-dep-value (dep-dependencies dep))
+ (recompute-dep-value dep)
+ (progn (setf (dep-flags dep) flags) nil))))))
+
+(defun %dep-value (dep)
+ "Do the difficult work of retrieving the current value of a DEP."
+ (when *evaluating-dep*
+ (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
+ (pushnew dep (dep-dependencies *evaluating-dep*)))
+ (force-dep-value dep))
+
+(declaim (inline dep-value))
+(defun dep-value (dep)
+ "Retrieve the current value from DEP."
+ (when (eq *state* :recomputing)
+ (%dep-value dep))
+ (let ((value (dep-%value dep)))
+ (if (eq value .bad.)
+ (throw 'dep-bad .bad.)
+ value)))
+
+(defun dep-goodp (dep)
+ "Answer whether DEP is good."
+ (when (eq *state* :recomputing)
+ (force-dep-value dep))
+ (not (eq (dep-%value dep) .bad.)))
+
+(defmacro dep-try (expr &body body)
+ "Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
+ (let ((block-name (gensym "TRY")))
+ `(block ,block-name
+ (catch 'dep-bad
+ (return-from ,block-name ,expr))
+ ,@body)))
+
+(defun dep-bad ()
+ "Call from a value-function: indicates that the dep should marked as bad."
+ (throw 'dep-bad nil))
+
+(defun recompute-pending-deps ()
+ "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
+
+ We bind *STATE* to :RECOMPUTING during the process."
+ (let ((*state* :recomputing))
+ (unwind-protect
+ (loop (when (queue-emptyp *pending-deps*)
+ (return))
+ (let* ((dep (dequeue *pending-deps*))
+ (flags (dep-%flags dep)))
+ (setf (dep-%flags dep) (logandc2 flags +queued+))
+ (cond ((zerop (logand flags +value+))
+ (recompute-dep-value dep))
+ ((zerop (logand flags +deps+))
+ (new-dep-value dep)
+ (setf (dep-%flags dep) (logior flags +deps+))))))
+ (loop (when (queue-emptyp *pending-deps*)
+ (return))
+ (let ((d (dequeue *pending-deps*)))
+ (setf (dep-%value d) .bad.))))))
+
+(defun with-deps-frozen* (thunk &key delay)
+ "Invoke THUNK in the :FROZEN state. See WITH-DEPS-FROZEN for full
+ information."
+ (ecase *state*
+ (:frozen
+ (funcall thunk))
(:recomputing
- (error "Ouch! Cyclic dependency."))))
-
-(defun pulse-dep (dep)
- "Notifies DEP of a change in its value. If a recomputation phase is
- currently under way, queue the dependents and leave fixing things up to
- the outer loop; otherwise start up a recomputation phase."
- (setf *generation* (list '*generation*))
- (flet ((kick (dep)
- (kick-dep dep)
- (when (dep-value-func dep)
- (catch 'dep-bad
- (let ((*evaluating-dep* (dep-weak-pointer dep)))
- (funcall (dep-value-func dep)))))))
- (if *pending-deps*
- (kick dep)
- (let ((*pending-deps* (make-queue)))
- (kick dep)
- (recompute-deps)))))
+ (unless delay
+ (error "This really isn't a good time."))
+ (enqueue thunk *delayed-operations*))
+ (:ready
+ (let ((*state* :frozen)
+ (*delayed-operations* (make-queue))
+ (*pending-deps* (make-queue)))
+ (setf *generation* (list '*generation*))
+ (multiple-value-prog1 (funcall thunk)
+ (loop (recompute-pending-deps)
+ (when (queue-emptyp *delayed-operations*)
+ (return))
+ (funcall (dequeue *delayed-operations*))))))))
+
+(defmacro with-deps-frozen ((&key delay) &body body)
+ "Evaluate BODY in the :FROZEN state.
+
+ In the :FROZEN state, recomutation is deferred. If the current state is
+ :READY, then we enter :FROZEN, evaluate the BODY, and then enter
+ :RECOMPUTING to fix up the dependency graph. If the current state is
+ :FROZEN, we do nothing particularly special. Finally, if the current
+ state is :RECOMPUTING then the behaviour depends on the value of
+ the :DELAY argument: if false, an error is signalled; if true, the
+ evaluation is postponed until the end of the recomputation.
+
+ This macro has four immediate uses.
+
+ * Firstly, it's actually the only way to trigger recomputation at all.
+ It's invoked behind the scenes to do the right thing.
+
+ * If you're making a large number of updates without data dependencies
+ then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
+ and only having a single recomputation phase.
+
+ * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
+ You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
+ assignment until later. Deferred operations take place in the order
+ in which they were requested.
+
+ * Finally, you can use it to force a number of deps to hold given values
+ simultaneously, despite their value-functions disagreeing."
+ `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
(defun (setf dep-value) (value dep)
- "Set DEP's value to be VALUE (and mark it as being good)."
- (when (update-dep dep value) (pulse-dep dep))
+ "Assign the VALUE to the DEP, forcing recomputation if necessary."
+ (with-deps-frozen ()
+ (when (update-dep dep value)
+ (setf (dep-generation dep) *generation*
+ (dep-flags dep) (logior +value+ +changed+))
+ (propagate-to-dependents dep)))
value)
(defun dep-make-bad (dep)
"Mark DEP as being bad."
- (when (update-dep dep nil nil) (pulse-dep dep)))
+ (setf (dep-value dep) .bad.))
(defun dep-add-listener (dep func)
"Add a listener function FUNC to the DEP. The FUNC is called each time the
and its return value is ignored."
(push func (dep-listeners dep)))
-(defun dep-value (dep)
- "Retrieve the current value from DEP."
- (when *evaluating-dep*
- (pushnew *evaluating-dep* (dep-dependents dep)))
- (ensure-dep-has-value dep)
- (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil)))
-
(defun make-dep (&rest args)
"Create a new DEP object. There are two basic argument forms:
(:value &optional OBJECT)
Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
- dep is initially bad. The keyword :leaf is accepted as a synonym.
+ dep is initially bad. The keyword :LEAF is accepted as a synonym.
(:function FUNCTION)
Return a non-leaf dep whose value is computed by FUNCTION.
retuerned (as if you'd specified :function); otherwise a leaf dep is
returned.
- Finally, it's possible to specify both :value and :function
+ Finally, it's possible to specify both :VALUE and :FUNCTION
simultaneously; this will set the initial values as requested, but
recompute them as necessary. It is possible to establish dependency
cycles, but you need to suppress recomputation in order to do this
(error "Not enough arguments to MAKE-DEP."))))
;; Sort out the arguments.
- (let ((value nil)
+ (let ((value .bad.)
(valuep nil)
+ (name nil)
(predicate #'eql)
+ (listeners nil)
(function nil))
(do () ((endp args))
(let ((indicator (pop args)))
(case indicator
((:value :leaf)
- (if args
- (setf value (pop args) valuep t)
- (setf value nil valuep t)))
+ (setf value (if args (pop args) .bad.)
+ valuep t))
(:function
(setf function (arg)))
(:predicate
(setf predicate (arg)))
+ (:name
+ (setf name (arg)))
+ (:listener
+ (push (arg) listeners))
(t
(cond ((functionp indicator)
(setf function indicator))
(t
- (setf value indicator valuep t)))))))
+ (setf value indicator
+ valuep t)))))))
+ (unless (or valuep function)
+ (setf valuep t))
;; Create the object appropriately.
- (let ((dep (%make-dep :value-func function
+ (let ((dep (%make-dep :value-function function
:%value value
- :state (if valuep :stable :pending)
+ :name name
+ :listeners listeners
+ :%flags (logior (if valuep +value+ 0)
+ (if function +queued+ +deps+)
+ +changed+)
:value-predicate predicate
- :generation (if function nil *generation*)
- :goodp valuep)))
+ :generation *generation*)))
(setf (dep-weak-pointer dep) (make-weak-pointer dep))
- (cond ((not function) t)
- (valuep (pulse-dep dep))
- (*pending-deps*
- (enqueue dep *pending-deps*))
- (t
- (let ((*pending-deps* (make-queue)))
- (enqueue dep *pending-deps*)
- (recompute-deps))))
- dep))))
-
-(defmacro dep-try (expr &body body)
- "Evaluate EXPR. If it throws dep-bad then evaluate BODY instead."
- (let ((block-name (gensym "TRY")))
- `(block ,block-name
- (catch 'dep-bad
- (return-from ,block-name ,expr))
- ,@body)))
-
-(defun dep-bad ()
- "Call from a value-func: indicates that the dep should marked as bad."
- (throw 'dep-bad nil))
-
-(defun delay-recomputing-deps* (thunk)
- "The guts of the DELAY-RECOMPUTING-DEPS macro. Evaluate THUNK without
- immediately updating dependencies until THUNK finishes. Returns the
- value(s) of THUNK."
- (if *pending-deps*
- (funcall thunk)
- (let ((*pending-deps* (make-queue)))
- (setf *generation* (list '*generation*))
- (multiple-value-prog1
- (funcall thunk)
- (recompute-deps)))))
-
-(defmacro delay-recomputing-deps (&body body)
- "Evaluate BODY, but delay recomputing any deps until the BODY completes
- execution.
-
- Note that deps can report incorrect values while delayed recomputation is
- in effect. In the current implementation, the direct dependents of a leaf
- dep whose value has changed will be correctly marked as pending (and
- recomputed as necessary); higher-level dependents won't be noticed until
- the direct dependents are recomputed.
-
- It can be used to apply a number of updates simultaneously to the system.
- This is useful for two reasons:
-
- * Firstly, it avoids the computational overheads of propagating changes
- repeatedly, so it can be used as a simple optimization.
-
- * Secondly, and perhaps more interestingly, it allows the values of
- mutually-dependent deps to be set simultaneously, even though the
- values being set may not be compatible with the deps' value
- functions."
- `(delay-recomputing-deps* #'(lambda () ,@body)))
+ (when function
+ (with-deps-frozen ()
+ (enqueue dep *pending-deps*)))
+ dep))))
(defun install-dep-syntax (&optional (readtable *readtable*))
"Installs into the given READTABLE some syntactic shortcuts:
readtable)
readtable)
+#- abcl
(defmethod print-object ((dep dep) stream)
(print-unreadable-object (dep stream :type t :identity t)
- (cond ((not (eq (dep-state dep) :stable))
- (format stream "~S" (dep-state dep)))
- ((dep-goodp dep)
- (format stream "~S ~W" :good (dep-%value dep)))
- (t
- (format stream "~S" :bad)))))
+ (pprint-logical-block (stream nil)
+ (let ((flags (dep-flags dep))
+ (value (dep-%value dep)))
+ (cond ((zerop (logand flags +value+))
+ (write-string "#<out-of-date>" stream))
+ ((eq value .bad.)
+ (write-string "#<bad>" stream))
+ (t
+ (write value :stream stream)))
+ (when (dep-name dep)
+ (format stream " ~_~S ~@_~W" :name (dep-name dep)))
+ (when (zerop (logand flags +deps+))
+ (format stream " ~_~S" :recompute-deps))
+ (when (plusp (logand flags +queued+))
+ (format stream " ~_~S" :queued))
+ (when (plusp (logand flags +changed+))
+ (format stream " ~_~S" :changed))))))
+
+;;;--------------------------------------------------------------------------
+;;; Tests.
#+ test
(progn
- (defparameter x (make-dep 1))
- (defparameter y (make-dep 2))
- (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
- (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
+ (defparameter x (make-dep :name 'x 1))
+ (defparameter y (make-dep :name 'y 2))
+ (defparameter z (make-dep :name 'z
+ (lambda () (+ (dep-value x) (dep-value y)))))
+ (defparameter w (make-dep :name 'w
+ (lambda () (* (dep-value x) (dep-value z)))))
(dep-add-listener x (lambda () (format t "x now ~A~%" x)))
(dep-add-listener z (lambda () (format t "z now ~A~%" z)))
(dep-add-listener w (lambda () (format t "w now ~A~%" w))))
+#+ test
+(progn
+ (defparameter a (make-dep :name 'a 1))
+ (defparameter b (make-dep :name 'b 2))
+ (defparameter c (make-dep :name 'c
+ (lambda () (1+ (dep-value a)))))
+ (defparameter d (make-dep :name 'd
+ (lambda () (* (dep-value c) (dep-value b)))))
+ (defparameter e (make-dep :name 'e
+ (lambda () (- (dep-value d) (dep-value a)))))
+ ;; a b c = a + 1 d = c*b e = d - a
+ ;; 1 2 2 4 3
+ ;; 4 2 5 10 6
+ (values (dep-value e)
+ (progn
+ (setf (dep-value a) 4)
+ (dep-value e))))
+
+#+ test
+(progn
+ (defparameter x nil)
+ (defparameter y nil)
+ (with-deps-frozen ()
+ (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
+ y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
+
+#+ test
+(trace with-deps-frozen* update-dep new-dep-value force-dep-value
+ recompute-dep-value recompute-pending-deps propagate-to-dependents
+ dep-value)
+
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff