From dea282e954a99fb02d0750d1b126e0db19879a3e Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sat, 29 Oct 2016 19:02:38 -0400
Subject: [PATCH] More refactoring of plan

Move action-status wholly to plan, merge it with planned-action-status.
Add a performable-p flag to plans.
Simplify sequential-plan and required-components; have them use a separate
function collect-action-dependencies for traversing the graph.
Add a function action-up-to-date-p to check whether an action is up-to-date,
without adding it to the plan if it wasn't.
---
 action.lisp  |  16 -----
 operate.lisp |   3 +
 plan.lisp    | 195 ++++++++++++++++++++++++++++++++-------------------
 session.lisp |   8 +--
 4 files changed, 129 insertions(+), 93 deletions(-)

diff --git a/action.lisp b/action.lisp
index 4e6ff76a0..4f76099dc 100644
--- a/action.lisp
+++ b/action.lisp
@@ -14,7 +14,6 @@
    #:non-propagating-operation
    #:component-depends-on
    #:input-files #:output-files #:output-file #:operation-done-p
-   #:action-status #:action-stamp #:action-done-p
    #:action-operation #:action-component #:make-action
    #:component-operation-time #:mark-operation-done #:compute-action-stamp
    #:perform #:perform-with-restarts #:retry #:accept #:*action*
@@ -395,21 +394,6 @@ Returns two values:
 * a boolean DONE-P that indicates whether the action has actually been done,
   and both its output-files and its in-image side-effects are up to date."))
 
-  (defclass action-status ()
-    ((stamp
-      :initarg :stamp :reader action-stamp
-      :documentation "STAMP associated with the ACTION if it has been completed already
-in some previous image, or T if it needs to be done.")
-     (done-p
-      :initarg :done-p :reader action-done-p
-      :documentation "a boolean, true iff the action was already done (before any planned action)."))
-    (:documentation "Status of an action"))
-
-  (defmethod print-object ((status action-status) stream)
-    (print-unreadable-object (status stream :type t)
-      (with-slots (stamp done-p) status
-        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
-
   (defmethod component-operation-time ((o operation) (c component))
     (gethash o (component-operation-times c)))
 
diff --git a/operate.lisp b/operate.lisp
index 8c2a21d4b..87bb0bcfe 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -87,6 +87,8 @@ But do NOT depend on it, for this is deprecated behavior."))
       (error 'missing-component-of-version :requires component :version version))
     (record-dependency nil operation component))
 
+  ;; TODO: have plans accept parent plans and delegate force and force-not.
+  ;; Ensure that only the toplevel session plan can specify force and force-not arguments.
   (defun ensure-plan (operation component
                       &rest keys &key plan-class &allow-other-keys)
     (declare (ignore operation))
@@ -97,6 +99,7 @@ But do NOT depend on it, for this is deprecated behavior."))
          session-plan)
         (t
          (let ((new (apply 'make-instance (or plan-class *plan-class*)
+                           :performable-p t
                            :system (component-system component) keys)))
            (setf (session-plan *asdf-session*) new)
            new)))))
diff --git a/plan.lisp b/plan.lisp
index 00a363b4b..59ffb3ce3 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -11,8 +11,8 @@
   (:export
    #:component-operation-time
    #:plan #:plan-traversal #:sequential-plan #:*plan-class*
-   #:action-status #:action-already-done-p
-   #:planned-action-status #:action-index #:action-planned-p
+   #:action-status #:action-stamp #:action-done-p #:action-index #:action-planned-p
+   #:action-already-done-p #:+action-status-out-of-date+
    #:circular-dependency #:circular-dependency-actions
    #:needed-in-image-p
    #:record-dependency
@@ -24,8 +24,8 @@
    #:plan-actions-r
    #:required-components #:filtered-sequential-plan
    #:plan-system
-   #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
-   #:traverse-actions #:traverse-sub-actions))
+   #:plan-component-type #:plan-keep-operation #:plan-keep-component
+   ))
 (in-package :asdf/plan)
 
 ;;;; Generic plan traversal class
@@ -33,7 +33,13 @@
   (defclass plan () ()
     (:documentation "Base class for a plan based on which ASDF can build a system"))
   (defclass plan-traversal (plan)
-    (;; The system for which the plan is computed
+    (;; Can this plan be performed? A plan that has different force and force-not settings than the
+     ;; session plan can only be used for read-only queries that do not cause the status of any
+     ;; action to be raised.
+     (performable-p :initform nil :initarg :performable-p :reader plan-performable-p)
+     ;; The parent plan from which this plan inherits forced status, etc.
+     (parent :initform nil :initarg :parent :reader plan-parent)
+     ;; The system for which the plan is computed
      (system :initform nil :initarg :system :accessor plan-system)
      ;; Table of systems specified via :force arguments
      (forced :initform nil :initarg :force :accessor forced)
@@ -44,6 +50,37 @@
 
 ;;;; Planned action status
 (with-upgradability ()
+  (defclass action-status ()
+    ((stamp
+      :initarg :stamp :reader action-stamp
+      :documentation "STAMP associated with the ACTION if it has been completed already
+in some previous image, or T if it needs to be done.")
+     (done-p
+      :initarg :done-p :reader action-done-p
+      :documentation "a boolean, true iff the action was already done (before any planned action).")
+     (planned-p
+      :initarg :planned-p :initform nil :reader action-planned-p
+      :documentation "a boolean, true iff the action was included in the plan.")
+     (index
+      :initarg :index :initform nil :reader action-index
+      :documentation "an integer, counting all traversed actions in traversal order, or NIL."))
+    (:documentation "Status of an action in a plan"))
+
+  (defparameter +action-status-out-of-date+ (make-instance 'action-status :stamp t :done-p nil))
+
+  (defun make-action-status (&key stamp done-p planned-p index)
+    (if (eq stamp t)
+        +action-status-out-of-date+
+        (make-instance 'action-status :stamp stamp :done-p done-p :planned-p planned-p :index index)))
+
+  (defmethod print-object ((status action-status) stream)
+    (print-unreadable-object (status stream :type t)
+      (with-slots (stamp done-p planned-p index) status
+        (format stream "~{~S~^ ~}"
+                `(:stamp ,stamp :done-p ,done-p
+                         ,@(when planned-p `(:planned-p ,planned-p))
+                         ,@(when index `(:index ,index)))))))
+
   (defgeneric action-status (plan operation component)
     (:documentation "Returns the ACTION-STATUS associated to
 the action of OPERATION on COMPONENT in the PLAN"))
@@ -52,30 +89,13 @@ the action of OPERATION on COMPONENT in the PLAN"))
     (:documentation "Sets the ACTION-STATUS associated to
 the action of OPERATION on COMPONENT in the PLAN"))
 
-  (defclass planned-action-status (action-status)
-    ((planned-p
-      :initarg :planned-p :reader action-planned-p
-      :documentation "a boolean, true iff the action was included in the plan.")
-     (index
-      :initarg :index :reader action-index
-      :documentation "an integer, counting all traversed actions in traversal order."))
-    (:documentation "Status of an action in a plan"))
-
-  (defmethod print-object ((status planned-action-status) stream)
-    (print-unreadable-object (status stream :type t :identity nil)
-      (with-slots (stamp done-p planned-p index) status
-        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))
-
-  (defmethod action-planned-p ((action-status t))
-    t) ; default method for non planned-action-status objects
-
   (defun action-already-done-p (plan operation component)
     "According to this plan, is this action already done and up to date?"
     (action-done-p (action-status plan operation component)))
 
   (defmethod action-status ((plan null) (o operation) (c component))
     (multiple-value-bind (stamp done-p) (component-operation-time o c)
-      (make-instance 'action-status :stamp stamp :done-p done-p)))
+      (make-action-status :stamp stamp :done-p done-p)))
 
   (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
     (let ((times (component-operation-times c)))
@@ -84,7 +104,6 @@ the action of OPERATION on COMPONENT in the PLAN"))
           (setf (gethash o times) (action-stamp new-status))))
     new-status))
 
-
 ;;;; forcing
 (with-upgradability ()
   (defgeneric action-forced-p (plan operation component)
@@ -281,7 +300,8 @@ initialized with SEED."
     (setf (gethash (cons o c) (visited-actions *asdf-session*)) new-status))
 
   (defmethod action-status ((p plan) (o operation) (c component))
-    (or (and (action-forced-not-p p o c) (action-status nil o c))
+    (if (action-forced-not-p p o c)
+        (action-status nil o c)
         (values (gethash (cons o c) (visited-actions *asdf-session*)))))
 
   (defgeneric record-dependency (plan operation component)
@@ -310,13 +330,43 @@ initialized with SEED."
   (defmethod action-status :around ((plan plan) operation component)
     ;; TODO: should we instead test something like:
     ;; (action-forced-not-p plan operation (primary-system component))
-      (if (action-forced-not-p plan operation component)
-          (let ((status (action-status nil operation component)))
-            (if (and (eq (type-of status) 'action-status) (action-done-p status))
-                status
-                (let ((stamp (and status (action-stamp status))))
-                  (make-instance 'action-status :done-p t :stamp stamp))))
-          (call-next-method)))
+    (if (action-forced-not-p plan operation component)
+        (let ((status (action-status nil operation component)))
+          (if (and status (action-done-p status))
+              status
+              (let ((stamp (and status (action-stamp status))))
+                (make-action-status :done-p t :stamp stamp))))
+        (call-next-method)))
+
+  ;; Different traversals:
+  ;; * Get the dependencies (filtered), don't change any status
+  ;; * Check whether some (defsystem-depends-on ?) dependencies are up to date
+  ;; * Check that some dependencies are up-to-date, though not necessarily in image
+  ;; * Check that some dependencies are up-to-date and in image, or add them to the plan
+
+  (defun action-up-to-date-p (plan operation component)
+    "Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan."
+    (while-visiting-action (operation component) ; maintain context, handle circularity.
+      (block nil
+        ;; Do NOT record the dependency: it might be out of date.
+        (let ((status (action-status plan operation component)))
+          (when status
+            (return (not (eq (action-stamp status) t)))))
+        (let* ((dependencies-up-to-date-p
+                (block nil
+                  (map-direct-dependencies ; recursively traverse dependencies
+                   operation component
+                   #'(lambda (o c) (unless (action-up-to-date-p plan o c) (return nil))))
+                  t))
+               (status
+                (if dependencies-up-to-date-p
+                    ;; If it's all up-to-date
+                    (multiple-value-bind (stamp done-p)
+                        (compute-action-stamp plan operation component) ; compute action stamp TODO: no plan!
+                      (make-action-status :stamp stamp :done-p done-p))
+                    +action-status-out-of-date+)))
+          (setf (action-status plan operation component) status)
+          (not (eq (action-stamp status) t))))))
 
   (defmethod traverse-action (plan operation component needed-in-image-p)
     (while-visiting-action (operation component) ; maintain context, handle circularity.
@@ -346,7 +396,7 @@ initialized with SEED."
                            (t
                             (setf (action-status plan operation component) ; update status:
                                   (make-instance
-                                   'planned-action-status
+                                   'action-status
                                    :stamp stamp ; computed stamp
                                    :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date?
                                    :planned-p add-to-plan-p ; included in list of things to be done?
@@ -431,8 +481,7 @@ initialized with SEED."
 ;;; files required by a bundling operation.
 (with-upgradability ()
   (defclass filtered-sequential-plan (sequential-plan)
-    ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
-     (component-type :initform t :initarg :component-type :reader plan-component-type)
+    ((component-type :initform t :initarg :component-type :reader plan-component-type)
      (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
      (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
     (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
@@ -444,49 +493,49 @@ initialized with SEED."
     ;; Ignore force and force-not, rely on other-systems:
     ;; force traversal of what we're interested in, i.e. current system or also others;
     ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
-    (with-slots (forced forced-not action-filter system) plan
-      (setf forced (normalize-forced-systems (if other-systems :all t) system))
-      (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))
-      (setf action-filter (ensure-function action-filter))))
-
-  (defmethod action-status :around ((plan filtered-sequential-plan) o c)
-    (if (and (funcall (plan-action-filter plan) o c)
-             (typep c (plan-component-type plan)))
-        (call-next-method)
-        (make-instance 'action-status :done-p t :stamp nil)))
-
-  (defun* (traverse-actions) (actions &rest keys &key plan-class &allow-other-keys)
-    "Given a list of actions, build a plan with these actions as roots."
-    (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
-      (loop* :for action :in actions
-             :as o = (action-operation action)
-             :as c = (action-component action)
-             :do (traverse-action plan o c t))
-      plan))
-
-  (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
-  (define-convenience-action-methods traverse-sub-actions (operation component &key))
-  (defmethod traverse-sub-actions ((operation operation) (component component)
-                                   &rest keys &key &allow-other-keys)
-    (apply 'traverse-actions (direct-dependencies operation component)
-           :system (component-system component) keys))
+    (with-slots (forced forced-not system) plan
+      (setf forced :all)
+      (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))))
 
   (defmethod plan-actions ((plan filtered-sequential-plan))
     (with-slots (keep-operation keep-component) plan
-      (loop* :for action :in (call-next-method)
-             :as o = (action-operation action)
-             :as c = (action-component action)
-             :when (and (typep o keep-operation) (typep c keep-component))
-             :collect (make-action o c))))
+      (loop :for action :in (call-next-method)
+        :as o = (action-operation action)
+        :as c = (action-component action)
+        :when (and (typep o keep-operation) (typep c keep-component))
+        :collect (cons o c))))
+
+  (defun collect-action-dependencies (plan operation component)
+    (while-visiting-action (operation component) ; maintain context, handle circularity.
+      (let ((action (make-action operation component)))
+        (unless (gethash action (visited-actions *asdf-session*))
+          (setf (gethash action (visited-actions *asdf-session*)) t)
+          (when (and (typep component (plan-component-type plan))
+                     (not (action-forced-not-p plan operation component)))
+            (map-direct-dependencies operation component
+                                     #'(lambda (o c) (collect-action-dependencies plan o c)))
+            (push action (plan-actions-r plan)))))))
+
+  (defgeneric collect-dependencies (operation component &key &allow-other-keys)
+    (:documentation "Given an action, build a plan for all of its dependencies."))
+  (define-convenience-action-methods collect-dependencies (operation component &key))
+  (defmethod collect-dependencies ((operation operation) (component component)
+                                   &rest keys &key &allow-other-keys)
+    (let ((plan (apply 'make-instance 'filtered-sequential-plan
+                       :system (component-system component) :force :all keys)))
+      (loop :for action :in (direct-dependencies operation component)
+        :do (collect-action-dependencies plan (action-operation action) (action-component action)))
+      (plan-actions plan)))
 
   (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
     "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
 return a list of the components involved in building the desired action."
-    (with-asdf-session (:override t)
-      (remove-duplicates
-       (mapcar 'action-component
-               (plan-actions
-                (apply 'traverse-sub-actions goal-operation system
-                       (remove-plist-key :goal-operation keys))))
-       :from-end t))))
+    (let ((cache (and *asdf-session* (session-cache *asdf-session*))))
+      (with-asdf-session (:override t)
+        (when cache (setf (session-cache *asdf-session*) cache))
+        (remove-duplicates
+         (mapcar 'action-component
+                 (apply 'collect-dependencies goal-operation system
+                        (remove-plist-key :goal-operation keys)))
+         :from-end t)))))
 
diff --git a/session.lisp b/session.lisp
index 8ef7e68c7..de1845c2a 100644
--- a/session.lisp
+++ b/session.lisp
@@ -1,5 +1,5 @@
 ;;;; -------------------------------------------------------------------------
-;;;; Session cache
+;;;; Session
 
 (uiop/package:define-package :asdf/session
   (:recycle :asdf/session :asdf/cache :asdf/component
@@ -10,7 +10,7 @@
    #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
    #:do-asdf-cache #:normalize-namestring
    #:call-with-asdf-session #:with-asdf-session
-   #:*asdf-session* #:*asdf-session-class* #:session #:session-plan
+   #:*asdf-session* #:*asdf-session-class* #:session #:session-cache #:session-plan
    #:visited-actions #:visiting-action-set #:visiting-action-list
    #:total-action-count #:planned-action-count #:planned-output-action-count
    #:clear-configuration-and-retry #:retry
@@ -36,8 +36,8 @@
      ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
      ;;   no expensive recomputations of transitive dependencies for input-files or output-files.
      ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
-     (cache
-      :initform (make-hash-table :test 'equal) :reader session-cache
+     (session-cache
+      :initform (make-hash-table :test 'equal) :accessor session-cache
       :documentation "Memoize expensive computations")
      (plan
       :initform nil :accessor session-plan
-- 
GitLab