[lisp] / dep.lisp

;;; -*-lisp-*-
;;;
;;; Maintenance and recalculation of dependent values
;;;
;;; (c) 2008 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(defpackage #:dep
  (:use #:common-lisp #:queue #:weak))
(in-package #:dep)

;;;--------------------------------------------------------------------------
;;; 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.
   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-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.

   Deps on the queue are always in the current generation, and have the
   +QUEUED+ flag set.")

;;;--------------------------------------------------------------------------
;;; Data structures.

(export '(dep depp dep-name))
(defstruct (dep (:predicate depp)
                (:constructor %make-dep))
  "There are two kinds of `dep', though we use the same object type for both.
   A leaf dep has no dependencies, and its value is set explicitly by the
   programmer.  A non-leaf dep has a value /function/, which computes the
   dep's value as a function of other deps' values.  The dependencies don't
   need to be declared in advance, or remain constant over time.

   When not during a recomputation phase (i.e., when `stable'), a dep is
   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 .bad. :type t)
  (name nil :type t :read-only t)
  (value-function nil :type (or function null) :read-only t)
  (value-predicate #'eql :type function :read-only t)
  (%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))

;;;--------------------------------------------------------------------------
;;; 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 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 (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
           (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))
    (:recomputing
     (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*))))))))

(export 'with-deps-frozen)
(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)
  "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)

(export 'dep-make-bad)
(defun dep-make-bad (dep)
  "Mark DEP as being bad."
  (setf (dep-value dep) .bad.))

(export 'dep-add-listener)
(defun dep-add-listener (dep func)
  "Add a listener function FUNC to the DEP.  The FUNC is called each time the
   DEP's value (or good/bad state) changes.  It is called with no arguments,
   and its return value is ignored."
  (push func (dep-listeners dep)))

(export 'make-dep)
(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.

   (:function FUNCTION)
        Return a non-leaf dep whose value is computed by FUNCTION.

   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 () (if args (pop args)
                     (error "Not enough arguments to MAKE-DEP."))))

    ;; Sort out the arguments.
    (let ((value .bad.)
          (valuep nil)
          (name nil)
          (predicate #'eql)
          (listeners nil)
          (function nil))
      (do () ((endp args))
        (let ((indicator (pop args)))
          (case indicator
            ((:value :leaf)
             (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)))))))
      (unless (or valuep function)
        (setf valuep t))

      ;; Create the object appropriately.
      (let ((dep (%make-dep :value-function function
                            :%value value
                            :name name
                            :listeners listeners
                            :%flags (logior (if valuep +value+ 0)
                                            (if function +queued+ +deps+)
                                            +changed+)
                            :value-predicate predicate
                            :generation *generation*)))
        (setf (dep-weak-pointer dep) (make-weak-pointer dep))
        (when function
          (with-deps-frozen ()
            (enqueue dep *pending-deps*)))
        dep))))

(export 'install-dep-syntax)
(defun install-dep-syntax (&optional (readtable *readtable*))
  "Installs into the given READTABLE some syntactic shortcuts:

   ?FORM -> (dep-value FORM)
        Extract (or modify, for a leaf dep) the value of the dep indicated by
        FORM.

   #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
        Return a derived dep whose value function computes the given FORMs
        (as an implicit PROGN)

   Returns the READTABLE."
  (set-macro-character #\?
                       (lambda (stream char)
                         (declare (ignore char))
                         (list 'dep-value (read stream t nil t)))
                       readtable)
  (set-syntax-from-char #\] #\) readtable readtable)
  (set-dispatch-macro-character #\# #\[
                                (lambda (stream arg char)
                                  (declare (ignore arg char))
                                  `(make-dep :function
                                             (lambda ()
                                               ,@(read-delimited-list #\]
                                                                      stream
                                                                      t))))
                                readtable)
  readtable)

#- abcl
(defmethod print-object ((dep dep) stream)
  (print-unreadable-object (dep stream :type t :identity t)
    (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 :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 --------------------------------------------------