- (catch 'dep-bad
- (setf (dep-state dep) :recomputing)
- (when (update-dep dep (let ((*evaluating-dep* 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))
+
+(export 'dep-value)
+(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)))
+
+(export 'dep-goodp)
+(defun dep-goodp (dep)
+ "Answer whether DEP is good."
+ (when (eq *state* :recomputing)
+ (force-dep-value dep))
+ (not (eq (dep-%value dep) .bad.)))
+
+(export 'dep-try)
+(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)))
+
+(export 'dep-bad)
+(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))