X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/2626af6648d844d428b3da1c12d1401e42405593..5f61c96135dd8b0e795f6e1e5d96708347fc8f5e:/dep.lisp diff --git a/dep.lisp b/dep.lisp index 5903743..7220975 100644 --- a/dep.lisp +++ b/dep.lisp @@ -22,9 +22,9 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (defpackage #:dep - (:use #:common-lisp #:queue) + (:use #:common-lisp #:queue #:weak) (: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)) @@ -33,6 +33,21 @@ ;;;-------------------------------------------------------------------------- ;;; 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. @@ -50,27 +65,21 @@ (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.") + (dependents 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." - (dolist (d (dep-dependents dep)) - (when (eq (dep-state d) :stable) - (enqueue d *pending-deps*) - (setf (dep-state d) :pending))) + (setf (dep-generation dep) *generation*) + (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)))) (setf (dep-dependents dep) nil) (dolist (l (dep-listeners dep)) (funcall l))) @@ -96,17 +105,19 @@ (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-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." @@ -136,26 +147,27 @@ "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-weak-pointer 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 @@ -173,56 +185,69 @@ (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) + (predicate #'eql) + (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))) + (:function + (setf function (arg))) + (:predicate + (setf predicate (arg))) + (t + (cond ((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) + :value-predicate predicate + :generation (if function nil *generation*) + :goodp valuep))) + (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)) - (: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." @@ -237,12 +262,13 @@ (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))))) @@ -257,9 +283,17 @@ 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: @@ -301,8 +335,8 @@ #+ test (progn - (defparameter x (make-leaf-dep 1)) - (defparameter y (make-leaf-dep 2)) + (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))))) (dep-add-listener x (lambda () (format t "x now ~A~%" x)))