Commit b7651034 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

plan: implement phase level escalation

Track at which level of nested calls to OPERATE a not-done action is needed;
if it is needed at a higher level than previously traversed, then traverse again
to schedule it (and its transitive dependencies) to be done in the higher level.
This fixes cases, such as in (test-system "cl-protobufs-tests"), where a library
was already marked as needed at a low level of OPERATE, but if actually needed
at higher level due to a defsystem-depends-on, and was previously not loaded
early enough (after this plan refactoring).
parent eed95a70
...@@ -82,7 +82,11 @@ But do NOT depend on it, for this is deprecated behavior.")) ...@@ -82,7 +82,11 @@ But do NOT depend on it, for this is deprecated behavior."))
(let* ((*verbose-out* (and verbose *standard-output*)) (let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings) (*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))) (*compile-file-failure-behaviour* on-failure)))
(call-next-method))) (unwind-protect
(progn
(incf (operate-level))
(call-next-method))
(decf (operate-level)))))
(defmethod operate :before ((operation operation) (component component) (defmethod operate :before ((operation operation) (component component)
&key version) &key version)
......
...@@ -60,11 +60,14 @@ ...@@ -60,11 +60,14 @@
(defclass action-status () (defclass action-status ()
((bits ((bits
:type fixnum :initarg :bits :reader status-bits :type fixnum :initarg :bits :reader status-bits
:documentation "a fixnum, bitmap describing the status of the action.") :documentation "bitmap describing the status of the action.")
(stamp (stamp
:type (or integer boolean) :initarg :stamp :reader status-stamp :type (or integer boolean) :initarg :stamp :reader status-stamp
:documentation "STAMP associated with the ACTION if it has been completed already :documentation "STAMP associated with the ACTION if it has been completed already in some
in some previous image, or T if it needs to be done.") previous sessino or image, T if it was done and builtin the image, or NIL if it needs to be done.")
(level
:type fixnum :initarg :level :initform 0 :reader status-level
:documentation "the highest (operate-level) at which the action was needed")
(index (index
:type (or integer null) :initarg :index :initform nil :reader status-index :type (or integer null) :initarg :index :initform nil :reader status-index
:documentation "INDEX associated with the ACTION in the current session, :documentation "INDEX associated with the ACTION in the current session,
...@@ -86,8 +89,12 @@ or NIL if no the status is considered outside of a specific plan.")) ...@@ -86,8 +89,12 @@ or NIL if no the status is considered outside of a specific plan."))
;; action is up-to-date with ACTION-UP-TO-DATE-P. ;; action is up-to-date with ACTION-UP-TO-DATE-P.
;; ;;
;; When traversing an action, the +need-bit+ is set, ;; When traversing an action, the +need-bit+ is set,
;; unless the action is up-to-date and not needed-in-image (HERE, SKIP). ;; unless the action is u p-to-date and not needed-in-image (HERE, SKIP).
;; When PERFORMing an action, the +done-bit+ is set. ;; When PERFORMing an action, the +done-bit+ is set.
;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of
;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then
;; its urgency (and that of its transitive dependencies) must be escalated so that it will be
;; done before the end of this level of operate.
;; ;;
;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value. ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value.
;; ;;
...@@ -106,19 +113,20 @@ or NIL if no the status is considered outside of a specific plan.")) ...@@ -106,19 +113,20 @@ or NIL if no the status is considered outside of a specific plan."))
(make-instance 'action-status :bits +void-bits+ :stamp nil))) (make-instance 'action-status :bits +void-bits+ :stamp nil)))
(with-upgradability () (with-upgradability ()
(defun make-action-status (&key bits stamp index) (defun make-action-status (&key bits stamp (level 0) index)
(check-type bits (integer 0 7)) (check-type bits (integer 0 7))
(check-type stamp (or integer boolean)) (check-type stamp (or integer boolean))
(check-type level (integer 0 #.most-positive-fixnum))
(check-type index (or integer null)) (check-type index (or integer null))
(assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) ()
"Bad action-status :bits ~S :stamp ~S" bits stamp) "Bad action-status :bits ~S :stamp ~S" bits stamp)
(block nil (block nil
(when (null index) (when (and (null index) (zerop level))
(case bits (case bits
(#.+void-bits+ (return +status-void+)) (#.+void-bits+ (return +status-void+))
(#.+todo-bits+ (return +status-todo+)) (#.+todo-bits+ (return +status-todo+))
(#.+good-bits+ (when (eq stamp t) (return +status-good+))))) (#.+good-bits+ (when (eq stamp t) (return +status-good+)))))
(make-instance 'action-status :bits bits :stamp stamp :index index))) (make-instance 'action-status :bits bits :stamp stamp :level level :index index)))
(defun status-keep-p (status) (defun status-keep-p (status)
(plusp (logand (status-bits status) #.+keep-bit+))) (plusp (logand (status-bits status) #.+keep-bit+)))
...@@ -132,21 +140,21 @@ or NIL if no the status is considered outside of a specific plan.")) ...@@ -132,21 +140,21 @@ or NIL if no the status is considered outside of a specific plan."))
(make-action-status (make-action-status
:bits (logand (status-bits status1) (status-bits status2)) :bits (logand (status-bits status1) (status-bits status2))
:stamp (latest-stamp (status-stamp status1) (status-stamp status2)) :stamp (latest-stamp (status-stamp status1) (status-stamp status2))
:level (max (status-level status1) (status-level status2))
:index (or (status-index status1) (status-index status2)))) :index (or (status-index status1) (status-index status2))))
(defun mark-status-needed (status) (defun mark-status-needed (status &optional (level (operate-level)))
"Return the same status but with the need bit set" "Return the same status but with the need bit set, for the given level"
(if (status-need-p status) (merge-action-status
status status
(make-action-status (make-action-status
:bits (logior (status-bits status) +need-bit+) :bits +need-bit+
:stamp (status-stamp status) :level level)))
:index (status-index status))))
(defmethod print-object ((status action-status) stream) (defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t) (print-unreadable-object (status stream :type t)
(with-slots (bits stamp) status (with-slots (bits stamp level index) status
(format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp))))) (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index)))))
(defgeneric action-status (plan operation component) (defgeneric action-status (plan operation component)
(:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT
...@@ -159,7 +167,7 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -159,7 +167,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(defmethod action-status ((plan null) (o operation) (c component)) (defmethod action-status ((plan null) (o operation) (c component))
(multiple-value-bind (stamp done-p) (component-operation-time o c) (multiple-value-bind (stamp done-p) (component-operation-time o c)
(if done-p (if done-p
(make-action-status :bits +good-bits+ :stamp stamp) (make-action-status :bits #.+keep-bit+ :stamp stamp)
+status-void+))) +status-void+)))
(defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
...@@ -346,6 +354,7 @@ initialized with SEED." ...@@ -346,6 +354,7 @@ initialized with SEED."
(if done-p #.+done-bit+ 0) (if done-p #.+done-bit+ 0)
(if need-p #.+need-bit+ 0)) (if need-p #.+need-bit+ 0))
:stamp stamp :stamp stamp
:level (operate-level)
:index (incf (total-action-count *asdf-session*))))) :index (incf (total-action-count *asdf-session*)))))
;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
...@@ -377,9 +386,11 @@ initialized with SEED." ...@@ -377,9 +386,11 @@ initialized with SEED."
;; effective niip: meaningful for the action and required by the plan as traversed ;; effective niip: meaningful for the action and required by the plan as traversed
(eniip (and aniip needed-in-image-p)) (eniip (and aniip needed-in-image-p))
;; status: have we traversed that action previously, and if so what was its status? ;; status: have we traversed that action previously, and if so what was its status?
(status (action-status plan operation component))) (status (action-status plan operation component))
(level (operate-level)))
(when (and status (when (and status
(or (status-need-p status) ;; already visited (or (status-done-p status) ;; all done
(and (status-need-p status) (<= level (status-level status))) ;; already visited
(and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip
(return)) ; Already visited with sufficient need-in-image level! (return)) ; Already visited with sufficient need-in-image level!
(labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
...@@ -387,7 +398,7 @@ initialized with SEED." ...@@ -387,7 +398,7 @@ initialized with SEED."
operation component #'(lambda (o c) (traverse-action plan o c niip))) operation component #'(lambda (o c) (traverse-action plan o c niip)))
;; AFTER dependencies have been traversed, compute action stamp ;; AFTER dependencies have been traversed, compute action stamp
(let* ((status (if status (let* ((status (if status
(mark-status-needed status) (mark-status-needed status level)
(compute-action-status plan operation component t))) (compute-action-status plan operation component t)))
(out-of-date-p (not (status-keep-p status))) (out-of-date-p (not (status-keep-p status)))
(to-perform-p (or out-of-date-p (and niip (not (status-done-p status)))))) (to-perform-p (or out-of-date-p (and niip (not (status-done-p status))))))
...@@ -544,10 +555,11 @@ return a list of the components involved in building the desired action." ...@@ -544,10 +555,11 @@ return a list of the components involved in building the desired action."
(defmethod mark-as-done ((plan plan) (o operation) (c component)) (defmethod mark-as-done ((plan plan) (o operation) (c component))
(let ((plan-status (action-status plan o c)) (let ((plan-status (action-status plan o c))
(perform-status (action-status nil o c))) (perform-status (action-status nil o c)))
(assert (and (status-stamp perform-status) (status-done-p perform-status)) () (assert (and (status-stamp perform-status) (status-keep-p perform-status)) ()
"Just performed ~A but failed to mark it done" (action-description o c)) "Just performed ~A but failed to mark it done" (action-description o c))
(setf (action-status plan o c) (setf (action-status plan o c)
(make-action-status (make-action-status
:bits (logior (status-bits perform-status) +done-bit+) :bits (logior (status-bits plan-status) +done-bit+)
:stamp (status-stamp perform-status) :stamp (status-stamp perform-status)
:level (status-level plan-status)
:index (status-index plan-status)))))) :index (status-index plan-status))))))
...@@ -15,6 +15,7 @@ ...@@ -15,6 +15,7 @@
#:visited-actions #:visiting-action-set #:visiting-action-list #:visited-actions #:visiting-action-set #:visiting-action-list
#:total-action-count #:planned-action-count #:planned-output-action-count #:total-action-count #:planned-action-count #:planned-output-action-count
#:clear-configuration-and-retry #:retry #:clear-configuration-and-retry #:retry
#:operate-level
;; conditions ;; conditions
#:system-definition-error ;; top level, moved here because this is the earliest place for it. #:system-definition-error ;; top level, moved here because this is the earliest place for it.
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error)) #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
...@@ -43,6 +44,11 @@ ...@@ -43,6 +44,11 @@
(session-cache (session-cache
:initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
:documentation "Memoize expensive computations") :documentation "Memoize expensive computations")
(operate-level
:initform 0 :initarg :operate-level :accessor session-operate-level
:documentation "Number of nested calls to operate we're under (for toplevel session only)")
;; shouldn't the below be superseded by the session-wide caching of action-status
;; for (load-op "asdf") ?
(asdf-upgraded-p (asdf-upgraded-p
:initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
:documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
...@@ -66,6 +72,12 @@ ...@@ -66,6 +72,12 @@
(defun toplevel-asdf-session () (defun toplevel-asdf-session ()
(when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))
(defun operate-level ()
(session-operate-level (toplevel-asdf-session)))
(defun (setf operate-level) (new-level)
(setf (session-operate-level (toplevel-asdf-session)) new-level))
(defun asdf-cache () (defun asdf-cache ()
(session-cache *asdf-session*)) (session-cache *asdf-session*))
......
(in-package :asdf-test) (in-package :asdf-test)
(defvar *od* 0) (defvar *od* 0)
(defsystem "overlapping-dependency" (defsystem "overlapping-dependency"
:components ((:file "overlapping-dependency")) ;;:perform (load-op (o c) (incf *od*)) ;; Now done in the file.
;;:perform (load-op (o c) (incf *od*)) :components ((:file "overlapping-dependency")))
)
...@@ -50,6 +50,8 @@ ...@@ -50,6 +50,8 @@
(asdf::clear-registered-systems) (asdf::clear-registered-systems)
(assert-equal *dd* 0) (assert-equal *dd* 0)
(with-asdf-session (:override t) (with-asdf-session (:override t)
;; get this (and asdf) out of the way, for simpler traces when tracing what matters.
(load-system "overlapping-dependency")
;; This is what causes an issue without phase escalation:
(test-system "defsystem-dependency")) (test-system "defsystem-dependency"))
(assert-equal *dd* 10) (assert-equal *dd* 10)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment