From a9c224421fc7d48a014d45d2f2f2c822e94fb523 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sat, 22 Oct 2016 18:03:07 -0400 Subject: [PATCH] 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. --- Makefile | 2 +- action.lisp | 51 +++- asdf.asd | 19 +- backward-interface.lisp | 2 +- bundle.lisp | 9 +- component.lisp | 19 +- find-component.lisp | 3 - find-system.lisp | 81 +++--- lisp-action.lisp | 2 +- make-asdf.bat | 2 +- make-asdf.sh | 2 +- operate.lisp | 23 +- operation.lisp | 2 +- package-inferred-system.lisp | 5 +- plan.lisp | 302 +++++++++----------- session.lisp | 85 ++++-- system.lisp | 15 +- test/script-support.lisp | 18 +- test/test-compile-file-failure.script | 3 +- test/test-deferred-warnings.script | 12 + test/test-defsystem-depends-on-circular.asd | 3 + test/test-defsystem-depends-on.script | 12 +- test/test-force.script | 12 + test/test-module-depend.script | 5 +- test/test-require.script | 8 +- test/test-sysdef-asdf.script | 8 +- test/test-undeferred-warnings.script | 2 + test/test-utilities.script | 8 - test/test-xach-update-bug.script | 3 +- 29 files changed, 405 insertions(+), 313 deletions(-) create mode 100644 test/test-defsystem-depends-on-circular.asd diff --git a/Makefile b/Makefile index c64cdf511..743ac9cd4 100644 --- a/Makefile +++ b/Makefile @@ -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 $* = $($*) diff --git a/action.lisp b/action.lisp index 1f6e7666b..ee9c8f7f3 100644 --- a/action.lisp +++ b/action.lisp @@ -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)))) + diff --git a/asdf.asd b/asdf.asd index 2e26ef5e3..8693b0e0f 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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")))) - diff --git a/backward-interface.lisp b/backward-interface.lisp index 9a0959e3b..d088dda33 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -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 diff --git a/bundle.lisp b/bundle.lisp index 20c1abc0e..b9f3c5d01 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -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: diff --git a/component.lisp b/component.lisp index 53d6d041d..cafeee3ec 100644 --- a/component.lisp +++ b/component.lisp @@ -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." diff --git a/find-component.lisp b/find-component.lisp index 145e8c011..e85c5dc59 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -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")) diff --git a/find-system.lisp b/find-system.lisp index 8f6fb845d..1458f2fd4 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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)) diff --git a/lisp-action.lisp b/lisp-action.lisp index 4ea0d2139..b34576729 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -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 diff --git a/make-asdf.bat b/make-asdf.bat index 4614e1254..5cad19737 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -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" diff --git a/make-asdf.sh b/make-asdf.sh index 7194e1716..fa65dcdef 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -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 diff --git a/operate.lisp b/operate.lisp index 003b07926..a5d8ffc19 100644 --- a/operate.lisp +++ b/operate.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)) diff --git a/operation.lisp b/operation.lisp index dbac55545..b03c04661 100644 --- a/operation.lisp +++ b/operation.lisp @@ -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 diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index 2dbc427bd..ebacb56bb 100644 --- a/package-inferred-system.lisp +++ b/package-inferred-system.lisp @@ -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. diff --git a/plan.lisp b/plan.lisp index 987e0d40e..3c90412e0 100644 --- a/plan.lisp +++ b/plan.lisp @@ -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 - (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) - (cond ; it needs be done if it's out of date or needed in image but absent - ((and add-to-plan-p (not niip)) ; if we need to do it, - (visit-action t)) ; then we need to do it *in the (current) image*! - (t - (setf (plan-action-status plan operation component) ; update status: - (make-instance - 'planned-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? - :index (if status ; index of action amongst all nodes in traversal - (action-index status) ;; if already visited, keep index - (incf (plan-total-action-count plan))))) ; else new index - (when (and done-p (not add-to-plan-p)) - (setf (component-operation-time operation component) stamp)) - (when add-to-plan-p ; if it needs to be added to the plan, - (incf (plan-planned-action-count plan)) ; count it - (unless aniip ; if it's output-producing, - (incf (plan-planned-output-action-count plan)))) ; count it - stamp)))))) ; return the stamp - (while-visiting-action (plan operation component) ; maintain context, handle circularity. + (while-visiting-action (operation component) ; maintain context, handle circularity. + (block nil + ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, + ;; instead of just a dependency order as in vanilla ASDF. + ;; TODO: It is also needed to detect OPERATE-in-PERFORM. + (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 (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 + 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 + (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) + (cond ; it needs be done if it's out of date or needed in image but absent + ((and add-to-plan-p (not niip)) ; if we need to do it, + (visit-action t)) ; then we need to do it *in the (current) image*! + (t + (setf (action-status plan operation component) ; update status: + (make-instance + 'planned-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? + :index (if status ;; index of action among all nodes in traversal + (action-index status) ;; keep index if already visited + ;; else allocate a new session-wide index + (incf (total-action-count *asdf-session*))))) + (when (and done-p (not add-to-plan-p)) + (setf (component-operation-time operation component) stamp)) + (when add-to-plan-p ; if it needs to be added to the plan, + (incf (planned-action-count *asdf-session*)) ; count it + (unless aniip ; if it's output-producing, + (incf (planned-output-action-count *asdf-session*)))) ; count it + stamp)))))) ; return the stamp (visit-action eniip))))))) ; visit the action @@ -430,10 +384,10 @@ initialized with SEED." (reverse (plan-actions-r plan))) ;; No need to record a dependency to build a full graph, just accumulate nodes in order. - (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component)) + (defmethod record-dependency ((plan sequential-plan) (o operation) (c component)) (values)) - (defmethod (setf plan-action-status) :after + (defmethod (setf action-status) :after (new-status (p sequential-plan) (o operation) (c component)) (when (action-planned-p new-status) (push (make-action o c) (plan-actions-r p))))) @@ -450,17 +404,17 @@ initialized with SEED." (defgeneric plan-operates-on-p (plan component) (:documentation "Does this PLAN include any operation on given COMPONENT?")) - (defvar *default-plan-class* 'sequential-plan + (defparameter* *plan-class* 'sequential-plan "The default plan class to use when building with ASDF") (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) - (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) - :system (component-system c) keys))) - (traverse-action plan o c t) - plan)) + (with-asdf-session () + (let ((plan (apply 'make-instance (or plan-class *plan-class*) + :system (component-system c) keys))) + (traverse-action plan o c t) + plan))) (defmethod perform-plan :around ((plan t) &key) - #+xcl (declare (ignorable plan)) (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () ;; backward-compatibility. @@ -471,10 +425,10 @@ initialized with SEED." (defmethod perform-plan ((steps list) &key force &allow-other-keys) (loop :for action :in steps - :as o = (action-operation action) - :as c = (action-component action) - :unless (nth-value 1 (compute-action-stamp nil o c)) - :do (perform-with-restarts o c))) + :as o = (action-operation action) + :as c = (action-component action) + :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) + :do (perform-with-restarts o c))) (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) (plan-operates-on-p (plan-actions plan) component-path)) @@ -508,10 +462,11 @@ initialized with SEED." (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system)) (setf action-filter (ensure-function action-filter)))) - (defmethod action-valid-p ((plan filtered-sequential-plan) o c) - (and (funcall (plan-action-filter plan) o c) - (typep c (plan-component-type plan)) - (call-next-method))) + (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." @@ -526,7 +481,7 @@ initialized with SEED." (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 t operation component) + (apply 'traverse-actions (direct-dependencies operation component) :system (component-system component) keys)) (defmethod plan-actions ((plan filtered-sequential-plan)) @@ -540,10 +495,11 @@ initialized with SEED." (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." - (remove-duplicates - (mapcar 'action-component - (plan-actions - (apply 'traverse-sub-actions goal-operation system - (remove-plist-key :goal-operation keys)))) - :from-end t))) + (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)))) diff --git a/session.lisp b/session.lisp index f8cb89d3b..8ef7e68c7 100644 --- a/session.lisp +++ b/session.lisp @@ -2,31 +2,59 @@ ;;;; Session cache (uiop/package:define-package :asdf/session - (:recycle :asdf/session :asdf/cache) + (:recycle :asdf/session :asdf/cache :asdf/component + :asdf/action :asdf/find-system :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) - (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #: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* #:caching-session - #:clear-configuration-and-retry #:retry)) + (:export + #:get-file-stamp #:compute-file-stamp #:register-file-stamp + #: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 + #:visited-actions #:visiting-action-set #:visiting-action-list + #:total-action-count #:planned-action-count #:planned-output-action-count + #:clear-configuration-and-retry #:retry + ;; conditions + #: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)) (in-package :asdf/session) -;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving: -;; * Consistency in the view of the world relied on by ASDF within a given session. -;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops -;; (a.k.a. stack overflows) and other erratic behavior. -;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and -;; no expensive recomputations of transitive dependencies for some input-files or output-files. -;; * Testability of ASDF with the ability to fake timestamps without actually touching files. (with-upgradability () ;; The session variable. ;; NIL when outside a session. (defvar *asdf-session* nil) - (defparameter* *asdf-session-class* 'caching-session) - (defclass caching-session () - ((cache :initform (make-hash-table :test 'equal) :reader session-cache))) + (defparameter* *asdf-session-class* 'session + "The default class for sessions") + + (defclass session () + (;; The ASDF session cache is used to memoize some computations. + ;; It is instrumental in achieving: + ;; * Consistency in the view of the world relied on by ASDF within a given session. + ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops + ;; (a.k.a. stack overflows) and other erratic behavior. + ;; * 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 + :documentation "Memoize expensive computations") + (plan + :initform nil :accessor session-plan + :documentation "Dependency graph of actions") + ;; Table that to actions already visited while walking the dependencies associates status + (visited-actions :initform (make-hash-table :test 'equal) :accessor 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 visiting-action-set) + (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list + ;; Counts of total actions in plan + (total-action-count :initform 0 :accessor total-action-count) + ;; Count of actions that need to be performed + (planned-action-count :initform 0 :accessor 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 planned-output-action-count)) + (:documentation "An ASDF session with a cache to memoize some computations")) (defun asdf-cache () (session-cache *asdf-session*)) @@ -112,5 +140,26 @@ (defun get-file-stamp (file) (when file (let ((namestring (normalize-namestring file))) - (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))) + (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) + + ;;; Conditions + + (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 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))))) + + (defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments))) diff --git a/system.lisp b/system.lisp index 8c71e5ba7..b1290c18b 100644 --- a/system.lisp +++ b/system.lisp @@ -5,12 +5,12 @@ (:recycle :asdf :asdf/system) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) (:export - #:system #:proto-system + #:system #:proto-system #:undefined-system #:reset-system #:system-source-file #:system-source-directory #:system-relative-pathname - #:reset-system #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license - #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on + #:definition-dependencies #:system-defsystem-depends-on + #:system-depends-on #:system-weakly-depends-on #:component-build-pathname #:build-pathname #:component-entry-point #:entry-point #:homepage #:system-homepage @@ -59,7 +59,7 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. - ((name) (source-file) #|(children) (children-by-names)|#) + ((name) (source-file)) (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when a SYSTEM is redefined and its class is modified.")) @@ -85,19 +85,24 @@ a SYSTEM is redefined and its class is modified.")) (entry-point :initform nil :initarg :entry-point :accessor component-entry-point) (source-file :initform nil :initarg :source-file :accessor system-source-file) + ;; This slot contains the *declared* defsystem-depends-on dependencies (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on :initform nil) + ;; This slot contains the *inferred* dependencies of define-op + (definition-dependencies :initform nil :accessor definition-dependencies) ;; these two are specially set in parse-component-form, so have no :INITARGs. (depends-on :reader system-depends-on :initform nil) (weakly-depends-on :reader system-weakly-depends-on :initform nil)) (:documentation "SYSTEM is the base class for top-level components that users may request ASDF to build.")) + (defclass undefined-system (system) () + (:documentation "System that was not defined yet.")) (defun reset-system (system &rest keys &key &allow-other-keys) "Erase any data from a SYSTEM except its basic identity, then reinitialize it based on supplied KEYS." - (change-class (change-class system 'proto-system) 'system) + (change-class (change-class system 'proto-system) 'undefined-system) (apply 'reinitialize-instance system keys))) diff --git a/test/script-support.lisp b/test/script-support.lisp index f0b1303d8..30f42baf3 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -32,7 +32,7 @@ Some constraints: #:action-name #:in-plan-p #:test-source #:test-fasl #:resolve-output #:output-location #:quietly #:join-namestrings - #:clear-cache)) + #:reset-session #:reset-session-visited)) (in-package :asdf-test) @@ -741,14 +741,14 @@ is bound, write a message and exit on an error. If (assert (asymval '#:*file3* :test-package)))) (defun join-namestrings (namestrings) - (with-output-to-string (s) - (loop :with separator = (acall :inter-directory-separator) - :for (n . morep) :on namestrings - :do (format s "~A~@[~C~]" n (and morep separator))))) - -(defun clear-cache () - ;; Or, should we preserve the timestamps? - (clrhash (acall :asdf-cache))) + (format nil (format nil "~~{~~A~~^~A~~}" (acall :inter-directory-separator)) namestrings)) + +(defun reset-session () + (set (asym :*asdf-session*) nil)) + +(defun reset-session-visited () + (clrhash (acall '#:visited-actions (asymval '#:*asdf-session*)))) + ;; These are shorthands for interactive debugging of test scripts: (!a diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index bab990f3a..7c94e8b84 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -1,5 +1,4 @@ ;;; -*- Lisp -*- - (def-test-system test-compile-file-failure :components ((:file "test-compile-file-failure"))) @@ -9,6 +8,8 @@ t) (compile-file-error () nil))) +(reset-session) + (with-expected-failure (#+gcl "GCL failure to report compile-file error") (assert (handler-case (let ((*compile-file-failure-behaviour* :error)) diff --git a/test/test-deferred-warnings.script b/test/test-deferred-warnings.script index c90850900..3744aac1d 100644 --- a/test/test-deferred-warnings.script +++ b/test/test-deferred-warnings.script @@ -45,15 +45,18 @@ (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-foo-only :force t))) +(reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-ufww c)))) (load-system :use-foo-with-wrapper :force t)) +(reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-usfo c)))) (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-setf-foo-only :force t))) +(reset-session) (DBG :tdw1 *warnings-file-type*) (assert (handler-case @@ -67,6 +70,7 @@ (unless *warnings-file-type* (leave-test "Your Lisp does not support deferred-warnings" 0)) +(reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) @@ -74,6 +78,7 @@ nil) (compile-warned-error () t))) +(reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) @@ -81,16 +86,19 @@ nil) (compile-warned-error () t))) +(reset-session) (let ((*compile-file-warnings-behaviour* :error)) (load-system :use-then-defun-foo)) (setf *compile-file-warnings-behaviour* :error) +(reset-session) (load-system :use-setf-then-defun-foo) ;; FIXME: on CCL, the defmacro warning is found while loading the defmacro fasl. ;; We should probably beef up the detection in reify-deferred-warnings, ;; possibly file a bug. +(reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (assert (handler-case @@ -99,6 +107,7 @@ ;;(t (c) (DBG :utdf0 c)) (:no-error (&rest values) (DBG :utdf1 values) nil)))) +(reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (assert (handler-case @@ -107,11 +116,14 @@ ;;(t (c) (DBG :ustdf0 c)) (:no-error (&rest values) (DBG :ustdf1 values) nil)))) +(reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) compile-warned-error #+sbcl compile-failed-error (let ((*compile-file-warnings-behaviour* :error)) (load-system :undefined-variables :force t))) + +(reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) null #+sbcl compile-failed-error diff --git a/test/test-defsystem-depends-on-circular.asd b/test/test-defsystem-depends-on-circular.asd new file mode 100644 index 000000000..f056fcc1f --- /dev/null +++ b/test/test-defsystem-depends-on-circular.asd @@ -0,0 +1,3 @@ +;;; -*- Lisp -*- +(defsystem "test-defsystem-depends-on-circular" + :defsystem-depends-on ("test-defsystem-depends-on-circular")) diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script index 1daca58e3..c01eaa28e 100644 --- a/test/test-defsystem-depends-on.script +++ b/test/test-defsystem-depends-on.script @@ -20,6 +20,7 @@ (assert-equal 0 l-operation:*x*) +(reset-session) (make :test-defsystem-depends-on-2) (assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system. @@ -29,10 +30,12 @@ :build-operation "does-not-exist" :components ((:file "file3"))) +(reset-session) (signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3)) (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword)) +(reset-session) ;;; FIXME: the following form triggers bug https://bugs.launchpad.net/asdf/+bug/1445638 (eval `(def-test-system test-defsystem-depends-on-4 :defsystem-depends-on ((:feature ,*newsym* "test-defsystem-depends-on-3")))) @@ -40,10 +43,17 @@ (assert (find-system "test-defsystem-depends-on-4")) (progn + (reset-session) (signals asdf:missing-dependency (def-test-system unloadable-system :defsystem-depends-on (nonexistent-system))) (assert (not (system-registered-p "unloadable-system")))) (progn (signals asdf:missing-dependency (find-system "test-defsystem-depends-on-missing-system")) - (assert (not (system-registered-p "test-defsystem-depends-on-missing-system")))) + (assert (typep (asdf::registered-system "test-defsystem-depends-on-missing-system") + 'asdf::undefined-system))) + +(progn + (signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular")) + (assert (typep (asdf::registered-system "test-defsystem-depends-on-circular") + 'asdf::undefined-system))) diff --git a/test/test-force.script b/test/test-force.script index 9c786d6f8..cfd539bfd 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -16,36 +16,43 @@ (assert file1) (assert file1-date) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force t))) (DBG "Check that :force t forces the current system but not its dependencies" plan) (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all))) (DBG "Check that :force :all forces the current system and its dependencies" plan) (assert plan) (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) (assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) (DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" plan) (assert plan) (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force-not :all))) (DBG "Check that :force-not :all means \"all systems\"" plan) (assert (null plan))) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not :all))) (DBG "Check that :force-not :all takes precedence over :force" plan) (assert (null plan))) +(reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not '(:test-asdf/force :test-asdf/force1)))) (DBG "Check that :force-not :all takes precedence over :force" plan) (assert (null plan))) +(reset-session-visited) (let* ((*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) (plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) (DBG "Check that immutable-systems will block forcing" plan) @@ -63,11 +70,13 @@ (assert-equal (get-file-stamp "file1.lisp") date1) (assert-equal (get-file-stamp file1) date2) +(reset-session-visited) (DBG "Check that require-system won't reload") (require-system 'test-asdf/force1) (assert-equal (get-file-stamp file1) date2) (assert-equal test-package::*file1* :modified) +(reset-session-visited) (DBG "Check that load-system will reload") (load-system 'test-asdf/force1) ;; FIXME: It is unclear why this fails (at least on mkcl even randomly) @@ -77,6 +86,7 @@ (assert-equal test-package::*file1* t)) ;; forced, it should be later +(reset-session-visited) (DBG "Check that force reloading loads again") (setf test-package::*file3* :reset) (load-system 'test-asdf/force :force :all) @@ -88,6 +98,7 @@ (setf test-package::*file3* :reset) +(reset-session-visited) (DBG "Check that require-system called with touched .asd won't reload the asdf.") (unset-asdf-cache-entry '(find-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf/force")) @@ -96,6 +107,7 @@ (assert-equal (asymval :*times-loaded* :test-asdf-system) 1) (assert-equal test-package::*file3* :reset) +(reset-session-visited) (DBG "Check that require-system called with untouched .asd won't reload the asdf.") (require-system 'test-asdf/force) diff --git a/test/test-module-depend.script b/test/test-module-depend.script index 1eaca67bd..97623a308 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -27,7 +27,8 @@ (touch-file file1.fasl :timestamp (- file3-date 90)) (touch-file file2.fasl :timestamp (- file3-date 30)) (touch-file file3.fasl :timestamp (- file3-date 15)) +(reset-session-visited) (load-system 'test-module-depend) -(assert-compare (>= (get-file-stamp file2.fasl) file3-date)) +(assert-compare (>= (- (get-file-stamp file2.fasl) file3-date) 0)) ;; does this properly go to the second level? -(assert-compare (>= (get-file-stamp file3.fasl) file3-date)) +(assert-compare (>= (- (get-file-stamp file3.fasl) file3-date) 0)) diff --git a/test/test-require.script b/test/test-require.script index 7b286cf4c..3b449df2f 100644 --- a/test/test-require.script +++ b/test/test-require.script @@ -74,7 +74,7 @@ (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- System `preloaded-system' won't be reloaded on `require-system' when cache is empty") -(clear-cache) +(reset-session) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") @@ -138,7 +138,7 @@ (assert (component-loaded-p "require-system/immutable")) ;; *YES* marked loaded! (DBG "- System `immutable-system' won't be reloaded when cache is empty") -(clear-cache) +(reset-session) (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") @@ -154,7 +154,7 @@ (assert-equal (component-version (registered-system "require-system/ordinary")) "1.0") (DBG "- Load-system loads system from the disk") -(clear-cache) +(reset-session) (load-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "2.0") @@ -191,7 +191,7 @@ (setf asdf::*system-definition-search-functions* (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*)) (asdf::clear-defined-systems) -(clear-cache) +(reset-session) (defun has-module-p (x) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index de87d3357..193f26286 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -73,7 +73,7 @@ ;; The data-punting upgrade will mess up component identity, so clear the cache -(clear-cache) +(reset-session) (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*) (clear-system "asdf") @@ -88,16 +88,14 @@ (load-system :asdf)) ;; Upgrading from a recent-enough version, the input-files method was preserved! ;; But we need to clear the cache for it not to be short-circuited. -(clear-cache) +(reset-session) + (assert (find-system "fooey" nil)) (setf *ticks* 9) (eval '(input-files 'load-op "uiop")) (assert-equal *ticks* 12) -;;; disabling this test on windows since it relies on running make-asdf.bat, which -;;; does not work for me under cygwin. - rpg 2016-03-20 - (defun bootstrap-lisp-files (file line-prefix) (with-input-file (input (subpathname *asdf-directory* file)) (loop :for line = (read-line input) diff --git a/test/test-undeferred-warnings.script b/test/test-undeferred-warnings.script index 940257958..76f05be34 100644 --- a/test/test-undeferred-warnings.script +++ b/test/test-undeferred-warnings.script @@ -7,6 +7,8 @@ (in-package :asdf-test) +(setf asdf/session:*asdf-session* nil) + (disable-deferred-warnings-check) (def-test-system :undefined-variables diff --git a/test/test-utilities.script b/test/test-utilities.script index 4e006cfa5..ae5c2c7d5 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -242,15 +242,7 @@ asdf/component:version asdf/operation:feature asdf/plan:index - asdf/plan:forced - asdf/plan:forced-not - asdf/plan:planned-action-count - asdf/plan:planned-output-action-count asdf/plan:planned-p - asdf/plan:total-action-count - asdf/plan:visited-actions - asdf/plan:visiting-action-set - asdf/plan:visiting-action-list asdf/system:bug-tracker asdf/system:build-pathname asdf/system:system-defsystem-depends-on diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index 37255f26f..c0ddfa6ec 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -1,7 +1,6 @@ ;;; -*- Lisp -*- -;; Disable cache between those two very different compilations. -(setf asdf/session:*asdf-session* nil) +(setf asdf/session:*asdf-session* nil) ;; disable cache between those two very different compilations. #-(and ecl ecl-bytecmp) (setf asdf::*load-system-operation* 'load-bundle-op) ;; This triggers a bug on ECL no more! -- GitLab