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

Move node visit information from plan to session

Significantly refactor plan internals.

Move visited-actions, visiting-action-set, visiting-action-list,
total-action-count, planned-action-count, planned-output-action-count
from plan to session (remove the plan- prefix to accessors).

Move sysdef-error from component to session.

Remove plan as a parameter of action-valid-p (made simple defun)
and while-visiting-action (both moved to action), but also
map-direct-dependencies, reduce-direct-dependencies, direct-dependencies.

Rename *default-plan-class* to *plan-class*,
plan-record-dependency to record-dependency,
plan-action-status to action-status
plan-forced (accessor) to forced, plan-forced-not (accessor) to forced-not.

Introduce define-op, and visit a suitable action while loading an asd file.
Accumulate inner operate dependencies in a slot definition-dependencies of
a registered system or a newly registered undefined-system.

Introduce reset-session or reset-session-visited in various tests,
so operations aren't considered as layered atop each other, but
as restarting from a fresh planning session.

Use with-asdf-session in required-components, make-plan.

Stop using node-for, use cons directly, now that operations are safe.

Export format-action from action.

Move some conditions and generic functions around and reorder dependencies.
parent f98aaa6b
......@@ -80,7 +80,7 @@ XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
print-% : ; @echo $* = $($*)
......
......@@ -3,15 +3,15 @@
(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system #:asdf/session :asdf/find-system :asdf/find-component :asdf/operation)
(:recycle :asdf/action :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
(:import-from :asdf/operation #:check-operation-constructor)
#-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions)
(:export
#:action #:define-convenience-action-methods
#:action-description
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:action-description #:format-action
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
#:non-propagating-operation
#:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
......@@ -20,7 +20,9 @@
#:perform #:perform-with-restarts #:retry #:accept
#:action-path #:find-action #:stamp #:done-p
#:operation-definition-warning #:operation-definition-error ;; condition
))
#:action-valid-p
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action))
(in-package :asdf/action)
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
......@@ -461,3 +463,40 @@ in some previous image, or T if it needs to be done.")
(action-description operation component)))
(mark-operation-done operation component)
(return))))))
;;;; Detection of circular dependencies
(with-upgradability ()
(defun (action-valid-p) (operation component)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
(and operation component
(if-let (it (component-if-feature component)) (featurep it) t)))
(define-condition circular-dependency (system-definition-error)
((actions :initarg :actions :reader circular-dependency-actions))
(:report (lambda (c s)
(format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
(circular-dependency-actions c)))))
(defun call-while-visiting-action (operation component fun)
"Detect circular dependencies"
(when (action-valid-p operation component)
(with-accessors ((action-set visiting-action-set)
(action-list visiting-action-list)) *asdf-session*
(let ((action (cons operation component)))
(when (gethash action action-set)
(error 'circular-dependency :actions
(member action (reverse action-list) :test 'equal)))
(setf (gethash action action-set) t)
(push action action-list)
(unwind-protect
(funcall fun)
(pop action-list)
(setf (gethash action action-set) nil))))))
;; Syntactic sugar for call-while-visiting-action
(defmacro while-visiting-action ((o c) &body body)
`(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
......@@ -45,23 +45,23 @@
:components
((:file "upgrade")
(:file "session" :depends-on ("upgrade"))
(:file "component" :depends-on ("upgrade"))
(:file "component" :depends-on ("session"))
(:file "operation" :depends-on ("session"))
(:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system" "session"))
(:file "action" :depends-on ("session" "system" "operation"))
(:file "find-system" :depends-on ("session" "system" "action"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("find-system"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action"))
(:file "lisp-action" :depends-on ("action" "find-system"))
(:file "plan" :depends-on ("lisp-action" "find-component"))
(:file "operate" :depends-on ("plan"))
(:file "parse-defsystem" :depends-on ("session" "system" "lisp-action" "operate"))
(:file "parse-defsystem" :depends-on ("system" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(:file "package-inferred-system" :depends-on ("find-system" "parse-defsystem"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "backward-internals" :depends-on ("find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("output-translations"))
(:file "interface" :depends-on
("parse-defsystem" "concatenate-source"
"output-translations" "source-registry" "package-inferred-system"
......@@ -85,4 +85,3 @@
#+asdf3 :builtin-system-p #+asdf3 t
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op "asdf/defsystem"))))
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:export
......
......@@ -323,9 +323,9 @@ or of opaque libraries shipped along the source code."))
;; your component-depends-on method must gather the correct dependencies in the correct order.
(while-collecting (collect)
(map-direct-dependencies
t o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equalp (pathname-type p) type)))
......@@ -441,7 +441,7 @@ or of opaque libraries shipped along the source code."))
:keep-operation 'basic-load-op))
(while-collecting (x) ;; resolve the sideway-dependencies of s
(map-direct-dependencies
t 'load-op s
'load-op s
#'(lambda (o c)
(when (and (typep o 'load-op) (typep c 'system))
(x c)))))))
......@@ -496,7 +496,6 @@ which is probably not what you want; you probably need to tweak your output tran
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
#+xcl (declare (ignorable o))
`((load-op ,s) ,@(call-next-method))))
#| ;; Example use:
......
......@@ -2,10 +2,11 @@
;;;; Components
(uiop/package:define-package :asdf/component
(:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:recycle :asdf/component :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:component #:component-find-path
#:find-component ;; methods defined in find-component
#:component-name #:component-pathname #:component-relative-pathname
#:component-parent #:component-system #:component-parent-pathname
#:child-component #:parent-component #:module
......@@ -29,7 +30,6 @@
#:sub-components
;; conditions
#:system-definition-error ;; top level, moved here because this is the earliest place for it.
#:duplicate-names
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
......@@ -81,15 +81,6 @@ or NIL for top-level components (a.k.a. systems)"))
(defgeneric source-file-type (component system)
(:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
;; over print-object; this is always conditions::%print-condition for
;; condition objects, which in turn does inheritance of :report options at
;; run-time. fortunately, inheritance means we only need this kludge here in
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmucl (:report print-object))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
......@@ -150,6 +141,10 @@ or NIL for top-level components (a.k.a. systems)"))
:initarg :build-operation :initform nil :reader component-build-operation))
(:documentation "Base class for all components of a build"))
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(defun component-find-path (component)
"Return a path from a root system to the COMPONENT.
The return value is a list of component NAMES; a list of strings."
......
......@@ -50,9 +50,6 @@
;;;; Finding components
(with-upgradability ()
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(defgeneric resolve-dependency-combination (component combinator arguments)
(:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
in the context of COMPONENT"))
......
......@@ -4,16 +4,15 @@
(uiop/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/session :asdf/component :asdf/system)
:asdf/session :asdf/component :asdf/operation :asdf/action :asdf/system)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd
#:find-system #:locate-system #:load-asd #:define-op
#:system-registered-p #:registered-system #:register-system
#:registered-systems* #:registered-systems
#:clear-system #:map-systems
#:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
#:load-system-definition-error #:error-name #:error-pathname #:error-condition
#:*system-definition-search-functions* #:search-for-system-definition
#:*central-registry* #:probe-asd #:sysdef-central-registry-search
......@@ -34,12 +33,6 @@
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
(parent :initform nil :reader missing-parent :initarg :parent)))
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
(apply 'format s (format-control c) (format-arguments c)))))
(define-condition load-system-definition-error (system-definition-error)
((name :initarg :name :reader error-name)
(pathname :initarg :pathname :reader error-pathname)
......@@ -48,11 +41,6 @@
(format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
(error-name c) (error-pathname c) (error-condition c)))))
(defun sysdef-error (format &rest arguments)
(error 'formatted-system-definition-error :format-control
format :format-arguments arguments))
;;; Canonicalizing system names
(defun coerce-name (name)
......@@ -117,7 +105,7 @@ or NIL if not found."
(check-type system system)
(let ((name (component-name system)))
(check-type name string)
(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
(asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
(unless (eq system (registered-system name))
(setf (gethash name *defined-systems*)
(cons (ignore-errors (get-file-stamp (system-source-file system)))
......@@ -395,6 +383,17 @@ Going forward, we recommend new users should be using the source-registry.")
;; the precise protocol between the two functions may change in the future (or not).
(first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
(defclass define-op (non-propagating-operation) ()
(:documentation "An operation to record dependencies on loading a .asd file."))
(defmethod component-depends-on ((o define-op) (s system))
`((load-op ,@(system-defsystem-depends-on s))
,@(loop* :for (o . c) :in (definition-dependencies s) :collect (list o c))
,@(call-next-method)))
(defmethod component-depends-on ((o operation) (c undefined-system))
(sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))
(defun load-asd (pathname
&key name (external-format (encoding-external-format (detect-encoding pathname)))
&aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
......@@ -402,27 +401,37 @@ Going forward, we recommend new users should be using the source-registry.")
NAME if supplied is the name of a system expected to be defined in that file.
Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(with-asdf-session ()
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
;; a global readtable that gets globally side-effected. Ouch.
;; Same for the *print-pprint-dispatch* table.
;; We should do something about that for ASDF3 if possible, or else ASDF4.
(*readtable* readtable)
(*print-pprint-dispatch* print-pprint-dispatch)
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (physicalize-pathname pathname))))
(handler-bind
(((and error (not missing-component))
#'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname :condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(load* pathname :external-format external-format))))))
(nest
(with-asdf-session ())
(with-standard-io-syntax)
(let* ((primary-name (primary-system-name (or name (pathname-name pathname))))
(*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
;; a global readtable that gets globally side-effected. Ouch.
;; Same for the *print-pprint-dispatch* table.
;; We should do something about that for ASDF3 if possible, or else ASDF4.
(*readtable* readtable)
(*print-pprint-dispatch* print-pprint-dispatch)
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (physicalize-pathname pathname)))
(operation (make-operation 'define-op))
(system (or (registered-system primary-name)
(let ((system
(make-instance 'undefined-system
:name primary-name :source-file pathname)))
(register-system system)
system)))))
(while-visiting-action (operation system))
(handler-bind
(((and error (not missing-component))
#'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname :condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(load* pathname :external-format external-format))))
(defvar *old-asdf-systems* (make-hash-table :test 'equal))
......
......@@ -4,7 +4,7 @@
(uiop/package:define-package :asdf/lisp-action
(:recycle :asdf/lisp-action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/component :asdf/system :asdf/find-system
:asdf/operation :asdf/action)
(:export
#:try-recompiling
......
......@@ -5,7 +5,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + action.lisp + find-system.lisp + find-component.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
cd "%~p0"
......
......@@ -6,7 +6,7 @@ here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp"
all () {
# Default action: bootstrap asdf.lisp
......
......@@ -87,14 +87,27 @@ But do NOT depend on it, for this is deprecated behavior."))
&key version &allow-other-keys)
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version))
(when *plan*
(plan-record-dependency *plan* operation component)))
(record-dependency nil operation component))
(defun ensure-plan (operation component
&rest keys &key plan-class &allow-other-keys)
(declare (ignore operation))
(let ((session-plan (session-plan *asdf-session*)))
(cond
(session-plan
;; TODO: ensure compatibility between force in the two plans.
session-plan)
(t
(let ((new (apply 'make-instance (or plan-class *plan-class*)
:system (component-system component) keys)))
(setf (session-plan *asdf-session*) new)
new)))))
(defmethod operate ((operation operation) (component component)
&rest keys &key plan-class &allow-other-keys)
(let ((*plan* (apply 'make-plan plan-class operation component #|:parent *plan*|# keys)))
(apply 'perform-plan *plan* keys)
(values operation *plan*)))
(let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys)
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
......
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:operation
#:*operations* #:make-operation #:find-operation
......
......@@ -4,8 +4,9 @@
(uiop:define-package :asdf/package-inferred-system
(:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
(:use :uiop/common-lisp :uiop
:asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
:asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/lisp-action
:asdf/parse-defsystem)
(:export
#:package-inferred-system #:sysdef-package-inferred-system-search
#:package-system ;; backward compatibility only. To be removed.
......
......@@ -5,27 +5,23 @@
;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions
;; that used to live there before 3.2.0.
(:recycle :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation :asdf/system
:asdf/session :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/operation :asdf/action :asdf/lisp-action :asdf/system
:asdf/find-component :asdf/find-system)
(:export
#:component-operation-time
#:plan #:plan-traversal #:sequential-plan #:*default-plan-class* #:*plan*
#:planned-action-status #:plan-action-status #:action-already-done-p
#:plan #:plan-traversal #:sequential-plan #:*plan-class*
#:action-status #:action-already-done-p
#:planned-action-status #:action-index #:action-planned-p
#:circular-dependency #:circular-dependency-actions
#:needed-in-image-p
#:action-index #:action-planned-p #:action-valid-p
#:plan-record-dependency
#:record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
#:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
#:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r
#:planned-p #:index #:forced #:forced-not
#:plan-actions-r
#:required-components #:filtered-sequential-plan
#:plan-system
#:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
......@@ -40,34 +36,19 @@
(;; 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 plan-forced)
(forced :initform nil :initarg :force :accessor forced)
;; Table of systems specified via :force-not argument (and/or immutable)
(forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
;; Counts of total actions in plan
(total-action-count :initform 0 :accessor plan-total-action-count)
;; Count of actions that need to be performed
(planned-action-count :initform 0 :accessor plan-planned-action-count)
;; Count of actions that need to be performed that have a non-empty list of output-files.
(planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
;; Table that to actions already visited while walking the dependencies associates status
(visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
;; Actions that depend on those being currently walked through, to detect circularities
(visiting-action-set ;; as a set
:initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)
(visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list
(:documentation "Base class for plans that simply traverse dependencies"))
(defvar *plan* nil
"The plan currently being executed"))
(forced-not :initform nil :initarg :force-not :accessor forced-not))
(:documentation "Base class for plans that simply traverse dependencies")))
;;;; Planned action status
(with-upgradability ()
(defgeneric plan-action-status (plan operation component)
(defgeneric action-status (plan operation component)
(:documentation "Returns the ACTION-STATUS associated to
the action of OPERATION on COMPONENT in the PLAN"))
(defgeneric (setf plan-action-status) (new-status plan operation component)
(defgeneric (setf action-status) (new-status session operation component)
(:documentation "Sets the ACTION-STATUS associated to
the action of OPERATION on COMPONENT in the PLAN"))
......@@ -90,13 +71,13 @@ the action of OPERATION on COMPONENT in the PLAN"))
(defun action-already-done-p (plan operation component)
"According to this plan, is this action already done and up to date?"
(action-done-p (plan-action-status plan operation component)))
(action-done-p (action-status plan operation component)))
(defmethod plan-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)
(make-instance 'action-status :stamp stamp :done-p done-p)))
(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
(defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
(let ((times (component-operation-times c)))
(if (action-done-p new-status)
(remhash o times)
......@@ -148,7 +129,7 @@ or predicate on system names, or NIL if none are forced, or :ALL if all are."
(defmethod action-forced-p (plan operation component)
(and
;; Did the user ask us to re-perform the action?
(action-override-p plan operation component 'plan-forced)
(action-override-p plan operation component 'forced)
;; You really can't force a builtin system and :all doesn't apply to it,
;; except if it's the specifically the system currently being built.
(not (let ((system (component-system component)))
......@@ -158,7 +139,7 @@ or predicate on system names, or NIL if none are forced, or :ALL if all are."
(defmethod action-forced-not-p (plan operation component)
;; Did the user ask us to not re-perform the action?
;; NB: force-not takes precedence over force, as it should
(action-override-p plan operation component 'plan-forced-not))
(action-override-p plan operation component 'forced-not))
(defmethod action-forced-p ((plan null) (operation operation) (component component))
nil)
......@@ -167,20 +148,6 @@ or predicate on system names, or NIL if none are forced, or :ALL if all are."
nil))
;;;; action-valid-p
(with-upgradability ()
(defgeneric action-valid-p (plan operation component)
(:documentation "Is this action valid to include amongst dependencies?"))
;; :if-feature will invalidate actions on components for which the features don't apply.
(defmethod action-valid-p ((plan t) (o operation) (c component))
(if-let (it (component-if-feature c)) (featurep it) t))
;; If either the operation or component was resolved to nil, the action is invalid.
(defmethod action-valid-p ((plan t) (o null) (c t)) nil)
(defmethod action-valid-p ((plan t) (o t) (c null)) nil)
;; If the plan is null, i.e., we're looking at reality,
;; then any action with actual operation and component objects is valid.
(defmethod action-valid-p ((plan null) (o operation) (c component)) t))
;;;; Is the action needed in this image?
(with-upgradability ()
(defgeneric needed-in-image-p (operation component)
......@@ -197,29 +164,28 @@ to be meaningful, or could it just as well have been done in another Lisp image?
;;;; Visiting dependencies of an action and computing action stamps
(with-upgradability ()
(defun* (map-direct-dependencies) (plan operation component fun)
(defun* (map-direct-dependencies) (operation component fun)
"Call FUN on all the valid dependencies of the given action in the given plan"
(loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:for dep-o = (find-operation operation dep-o-spec)
:when dep-o
:do (loop :for dep-c-spec :in dep-c-specs
:for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
:when (and dep-c (action-valid-p plan dep-o dep-c))
:do (funcall fun dep-o dep-c))))
(defun* (reduce-direct-dependencies) (plan operation component combinator seed)
:for dep-o = (find-operation operation dep-o-spec)
:when dep-o
:do (loop :for dep-c-spec :in dep-c-specs
:for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
:when (action-valid-p dep-o dep-c)
:do (funcall fun dep-o dep-c))))
(defun* (reduce-direct-dependencies) (operation component combinator seed)
"Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
for each dependency action on the dependency's operation and component and an accumulator
initialized with SEED."
(map-direct-dependencies
plan operation component
#'(lambda (dep-o dep-c)
(setf seed (funcall combinator dep-o dep-c seed))))
operation component
#'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed))))
seed)
(defun* (direct-dependencies) (plan operation component)
(defun* (direct-dependencies) (operation component)
"Compute a list of the direct dependencies of the action within the plan"
(reverse (reduce-direct-dependencies plan operation component #'acons nil)))
(reverse (reduce-direct-dependencies operation component #'acons nil)))
;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
;; shall also be parametrized by the plan, or by a second model object,
......@@ -243,9 +209,9 @@ initialized with SEED."
(block ())
(let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)
(reduce-direct-dependencies
plan o c
o c
#'(lambda (o c stamp)
(if-let (it (plan-action-status plan o c))
(if-let (it (action-status plan o c))
(latest-stamp stamp (action-stamp it))
t))
nil)))
......@@ -311,48 +277,25 @@ initialized with SEED."
(defmethod plan-actions ((plan list))
plan)
(defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component))
(setf (gethash (cons o c) (plan-visited-actions p)) new-status))
(defmethod plan-action-status ((p plan-traversal) (o operation) (c component))
(or (and (action-forced-not-p p o c) (plan-action-status nil o c))
(values (gethash (cons o c) (plan-visited-actions p)))))
(defmethod (setf action-status) (new-status (p plan) (o operation) (c component))
(setf (gethash (cons o c) (visited-actions *asdf-session*)) new-status))
(defmethod action-valid-p ((p plan-traversal) (o operation) (s system))
(and (not (action-forced-not-p p o s)) (call-next-method)))
(defmethod action-status ((p plan) (o operation) (c component))
(or (and (action-forced-not-p p o c) (action-status nil o c))
(values (gethash (cons o c) (visited-actions *asdf-session*)))))
(defgeneric plan-record-dependency (plan operation component)
(:documentation "Record an action as a dependency in the current plan")))
(defgeneric record-dependency (plan operation component)
(:documentation "Record an action as a dependency in the current plan"))
;;;; Detection of circular dependencies
(with-upgradability ()
(define-condition circular-dependency (system-definition-error)
((actions :initarg :actions :reader circular-dependency-actions))
(:report (lambda (c s)
(format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
(circular-dependency-actions c)))))
(defgeneric call-while-visiting-action (plan operation component function)
(:documentation "Detect circular dependencies"))
(defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
(with-accessors ((action-set plan-visiting-action-set)
(action-list plan-visiting-action-list)) plan
(let ((action (make-action operation component)))
(when (gethash action action-set)
(error 'circular-dependency :actions
(member action (reverse action-list) :test 'equal)))
(setf (gethash action action-set) t)
(push action action-list)
(unwind-protect
(funcall fun)
(pop action-list)
(setf (gethash action action-set) nil)))))
;; Syntactic sugar for call-while-visiting-action
(defmacro while-visiting-action ((p o c) &body body)
`(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))))
(defmethod record-dependency ((plan null) (operation t) (component t))
(let* ((action (first (visiting-action-list *asdf-session*)))
(parent-operation (action-operation action))
(parent-component (action-component action)))
(when (and parent-operation parent-component)
(unless (and (typep parent-operation 'define-op) (typep parent-component 'system))
(cerror "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S"
operation component action))
(push action (definition-dependencies parent-component))))))
;;;; Actual traversal: traverse-action
......@@ -373,50 +316,61 @@ initialized with SEED."
;; to traverse each node at most twice; non-niip actions would be traversed only once,
;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
;; Handle FORCED-NOT: it makes an action return its current timestamp as status
(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)))
(defmethod traverse-action (plan operation component needed-in-image-p)
(block nil
;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT,
;; and IF-FEATURE filtering.
(unless (action-valid-p plan operation component) (return nil))
;; the following hook is needed by POIU, which tracks a full dependency graph,
;; instead of just a dependency order as in vanilla ASDF
(plan-record-dependency plan operation component)
;; needed in image distinguishes b/w things that must happen in the
;; current image and those things that simply need to have been done in a previous one.
(let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
;; effective niip: meaningful for the action and required by the plan as traversed
(eniip (and aniip needed-in-image-p))
;; status: have we traversed that action previously, and if so what was its status?
(status (plan-action-status plan operation component)))
(when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
(return (action-stamp status))) ; Already visited with sufficient need-in-image level!
(labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
(map-direct-dependencies ; recursively traverse dependencies
plan operation component #'(lambda (o c) (traverse-action plan o c niip)))
(multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed,
(compute-action-stamp plan operation component) ; compute action stamp