(defpackage #:dep
(:use #:common-lisp #:queue)
(:export #:dep #:depp #:make-dep #:dep-goodp
- :delay-recomputing-deps
+ #:delay-recomputing-deps
#:install-dep-syntax
#:dep-value #:dep-make-bad #:dep-bad #:dep-try
#:dep-add-listener))
;;;--------------------------------------------------------------------------
;;; Dependencies.
+(defvar *generation* (list '*generation*)
+ "Generation marker, used to remember when we last updated a particular dep.
+ Essentially, if the dep's generation matches *GENERATION* then it doesn't
+ need updating again.")
+
+(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
+ function's evaluation.")
+
+(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.")
+
(defstruct (dep (:predicate depp)
(:constructor %make-dep))
"There are two kinds of `dep', though we use the same object type for both.
(value-predicate #'eql :type function)
(goodp nil :type boolean)
(state :pending :type (member :stable :pending :recomputing))
+ (generation *generation* :type list)
(listeners nil :type list)
(dependents nil :type list))
-(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
- function's evaluation.")
-
-(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.")
-
(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*)
(dolist (d (dep-dependents dep))
(when (eq (dep-state d) :stable)
(enqueue d *pending-deps*)
(defun recompute-dep (dep)
"Recompute the value of DEP. This function is careful to trap nonlocal
transfers from the value-func."
- (let ((winning nil))
- (unwind-protect
- (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))))))
+ (unless (eq (dep-generation dep) *generation*)
+ (let ((winning nil))
+ (unwind-protect
+ (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."
"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."
- (if *pending-deps*
- (kick-dep dep)
- (let ((*pending-deps* (make-queue)))
- (kick-dep dep)
- (recompute-deps))))
+ (setf *generation* (list '*generation*))
+ (flet ((kick (dep)
+ (kick-dep dep)
+ (when (dep-value-func dep)
+ (catch 'dep-bad
+ (let ((*evaluating-dep* dep))
+ (funcall (dep-value-func dep)))))))
+ (if *pending-deps*
+ (kick dep)
+ (let ((*pending-deps* (make-queue)))
+ (kick dep)
+ (recompute-deps)))))
(defun (setf dep-value) (value dep)
"Set DEP's value to be VALUE (and mark it as being good)."
- (when (dep-value-func dep)
- (error "Not a leaf dep."))
- (when (update-dep dep value)
- (pulse-dep dep))
+ (when (update-dep dep value) (pulse-dep dep))
value)
(defun dep-make-bad (dep)
"Mark DEP as being bad."
- (when (dep-value-func dep)
- (error "Not a leaf dep."))
- (when (update-dep dep nil nil)
- (pulse-dep dep)))
+ (when (update-dep dep nil nil) (pulse-dep dep)))
(defun dep-add-listener (dep func)
"Add a listener function FUNC to the DEP. The FUNC is called each time the
(defun make-dep (&rest args)
"Create a new DEP object. There are two basic argument forms:
- (:leaf &optional OBJECT)
+ (:value &optional OBJECT)
Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
- dep is initially bad.
+ 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.
- Additionally, if the first argument is something other than :leaf or
- :function (ideally not a keyword, for forward compatibility), then the
+ Additionally, if the first argument is something other than :VALUE or
+ :FUNCTION (ideally not a keyword, for forward compatibility), then the
first argument is inspected: if it's a function, then a function dep is
retuerned (as if you'd specified :function); otherwise a leaf dep is
returned.
+ 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
+ correctly -- see the DELAY-RECOMPUTING-DEPS macro.
+
If no arguments are given, a bad leaf dep is returned."
- (flet ((arg (&optional (default nil defaultp))
- (cond (args (pop args))
- (defaultp default)
- (t (error "Not enough arguments to MAKE-DEP.")))))
+ (flet ((arg () (if args (pop args)
+ (error "Not enough arguments to MAKE-DEP."))))
;; Sort out the arguments.
- (multiple-value-bind (type value goodp)
- (if (null args)
- (values :leaf nil nil)
- (let ((indicator (pop args)))
- (cond ((eq indicator :leaf)
- (if args
- (values :leaf (pop args) t)
- (values :leaf nil nil)))
- ((eq indicator :function)
- (values :function (arg) nil))
- ((functionp indicator)
- (values :function indicator nil))
- (t
- (values :leaf indicator t)))))
- (unless (endp args)
- (error "Excess arguments to MAKE-DEP."))
+ (let ((value nil)
+ (valuep nil)
+ (function nil))
+ (do () ((endp args))
+ (let ((indicator (pop args)))
+ (cond ((or (eq indicator :value)
+ (eq indicator :leaf))
+ (if args
+ (setf value (pop args) valuep t)
+ (setf value nil valuep t)))
+ ((eq indicator :function)
+ (setf function (arg)))
+ ((functionp indicator)
+ (setf function indicator))
+ (t
+ (setf value indicator valuep t)))))
;; Create the object appropriately.
- (case type
- (:function
- (let ((dep (%make-dep :value-func value :state :pending)))
- (if *pending-deps*
- (enqueue dep *pending-deps*)
+ (let ((dep (%make-dep :value-func function
+ :%value value
+ :state (if valuep :stable :pending)
+ :generation (if function nil *generation*)
+ :goodp valuep)))
+ (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))
- (:leaf
- (%make-dep :%value value :goodp goodp :state :stable))))))
+ (recompute-deps))))
+ dep))))
(defmacro dep-try (expr &body body)
"Evaluate EXPR. If it throws dep-bad then evaluate BODY instead."
(throw 'dep-bad nil))
(defun delay-recomputing-deps* (thunk)
- "The guts of the DELAY-RECOMPUTATING-DEPS macro. Evaluate THUNK without
+ "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)))))
recomputed as necessary); higher-level dependents won't be noticed until
the direct dependents are recomputed.
- This form is intended to be used for bulk update to leaves, for which
- purpose it is fairly safe."
- `(delay-recomputating-deps* #'(lambda () ,@body)))
+ 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)))
(defun install-dep-syntax (&optional (readtable *readtable*))
"Installs into the given READTABLE some syntactic shortcuts:
~mdw / lisp / commitdiff