diff --git a/find-system.lisp b/find-system.lisp index 7b56b083c3cb25acbaed13ccabcb05a8e0610334..bf711eadea226ae093504b8565d0fc68e7e00f4f 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -8,8 +8,7 @@ :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) (:export #:find-system #:locate-system #:load-asd #:define-op - #:load-system-definition-error #:error-name #:error-pathname #:error-condition - )) + #:load-system-definition-error #:error-name #:error-pathname #:error-condition)) (in-package :asdf/find-system) (with-upgradability () diff --git a/operate.lisp b/operate.lisp index 87bb0bcfecbbabeb49445ec4862f3cafb6887dc8..9a4538d2ad3eb70fdfd868154ebb69fd5daf7c19 100644 --- a/operate.lisp +++ b/operate.lisp @@ -44,9 +44,6 @@ But do NOT depend on it, for this is deprecated behavior.")) (define-convenience-action-methods operate (operation component &key) :if-no-component (error 'missing-component :requires component)) - (defvar *in-operate* nil - "Are we in operate?") - ;; This method ensures that an ASDF upgrade is attempted as the very first thing, ;; with suitable state preservation in case in case it actually happens, ;; and that a few suitable dynamic bindings are established. @@ -56,9 +53,7 @@ But do NOT depend on it, for this is deprecated behavior.")) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) (nest (with-asdf-session ()) - (let ((in-operate *in-operate*) - (*in-operate* t) - (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) + (let ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) (etypecase operation (operation (let ((name (type-of operation))) #'(lambda () (make-operation name)))) @@ -69,12 +64,14 @@ But do NOT depend on it, for this is deprecated behavior.")) ;; Before we operate on any system, make sure ASDF is up-to-date, ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. (progn - (unless in-operate + (unless (asdf-upgraded-p (toplevel-asdf-session)) + (setf (asdf-upgraded-p (toplevel-asdf-session)) t) (when (upgrade-asdf) ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined. (return-from operate - (apply 'operate (funcall operation-remaker) component-path keys))))) + (with-asdf-session (:override t) + (apply 'operate (funcall operation-remaker) component-path keys)))))) ;; Setup proper bindings around any operate call. (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) diff --git a/plan.lisp b/plan.lisp index 59ffb3ce3826666bf57a16fe433a8aa0dc8e630b..edadac948055e530c9b141b83d0589570b32f515 100644 --- a/plan.lisp +++ b/plan.lisp @@ -530,12 +530,10 @@ 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." - (let ((cache (and *asdf-session* (session-cache *asdf-session*)))) - (with-asdf-session (:override t) - (when cache (setf (session-cache *asdf-session*) cache)) - (remove-duplicates - (mapcar 'action-component - (apply 'collect-dependencies goal-operation system - (remove-plist-key :goal-operation keys))) - :from-end t))))) + (with-asdf-session (:override t) + (remove-duplicates + (mapcar 'action-component + (apply 'collect-dependencies goal-operation system + (remove-plist-key :goal-operation keys))) + :from-end t)))) diff --git a/session.lisp b/session.lisp index de1845c2a09ff1ae6bdb46384b03b18d6c3b531d..280213810a8b1ce91e1dd6fb07f774b260b339fc 100644 --- a/session.lisp +++ b/session.lisp @@ -10,7 +10,8 @@ #: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-cache #:session-plan + #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session + #:session-cache #:session-plan #:asdf-upgraded-p #:visited-actions #:visiting-action-set #:visiting-action-list #:total-action-count #:planned-action-count #:planned-output-action-count #:clear-configuration-and-retry #:retry @@ -36,9 +37,15 @@ ;; * 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. + (ancestor + :initform nil :initarg :ancestor :reader session-ancestor + :documentation "Top level session that this is part of") (session-cache - :initform (make-hash-table :test 'equal) :accessor session-cache + :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache :documentation "Memoize expensive computations") + (asdf-upgraded-p + :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p + :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") (plan :initform nil :accessor session-plan :documentation "Dependency graph of actions") @@ -56,6 +63,9 @@ (planned-output-action-count :initform 0 :accessor planned-output-action-count)) (:documentation "An ASDF session with a cache to memoize some computations")) + (defun toplevel-asdf-session () + (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) + (defun asdf-cache () (session-cache *asdf-session*)) @@ -93,13 +103,18 @@ ;; Second, if a new session was started, establish restarts for retrying the overall computation. ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache ;; entry isn't found, or just call the THUNK if no KEY was specified. - (defun call-with-asdf-session (thunk &key override key) + (defun call-with-asdf-session (thunk &key override key override-cache) (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) - (if (and *asdf-session* (not override)) + (if (and (not override) *asdf-session*) (funcall fun) (loop (restart-case - (let ((*asdf-session* (make-instance *asdf-session-class*))) + (let ((*asdf-session* + (apply 'make-instance *asdf-session-class* + (when *asdf-session* + `(:ancestor ,(toplevel-asdf-session) + ,@(unless override-cache + `(:session-cache ,(session-cache *asdf-session*)))))))) (return (funcall fun))) (retry () :report (lambda (s) @@ -107,11 +122,13 @@ (clear-configuration-and-retry () :report (lambda (s) (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>"))) + (clrhash (session-cache *asdf-session*)) (clear-configuration))))))) ;; Syntactic sugar for call-with-asdf-session - (defmacro with-asdf-session ((&key key override) &body body) - `(call-with-asdf-session #'(lambda () ,@body) :override ,override :key ,key)) + (defmacro with-asdf-session ((&key key override override-cache) &body body) + `(call-with-asdf-session + #'(lambda () ,@body) :override ,override :key ,key :override-cache ,override-cache)) ;;; Define specific accessor for file (date) stamp. diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 74bb3d8332c70b3136fe2e96c89cb0a1e634384f..228fc3b113977da038d3cd285270636738bcaac1 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -1,9 +1,12 @@ ;;-*- Lisp -*- +(setf *asdf-session* nil) + (defun current-system-source-file (x) (system-source-file (asdf::registered-system x))) (with-asdf-session (:override t) + (terpri) (DBG "loading test-mutual-redefinition-1") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) @@ -19,7 +22,8 @@ (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-2")) - (DBG "loading test-mutual-redefinition-2 in the same cache session") + (terpri) + (DBG "loading test-mutual-redefinition-2 in the same cache session. It shouldn't affect asd paths") (load-system 'test-mutual-redefinition-2) (assert-pathname-equal (test-source "test-mutual-redefinition-1.asd") @@ -29,6 +33,7 @@ (current-system-source-file "test-mutual-redefinition-2"))) (with-asdf-session (:override t) + (terpri) (DBG "loading test-mutual-redefinition-2 in a different cache session") (load-system 'test-mutual-redefinition-2) (assert-pathname-equal diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index adb1bd7e58831e2b5d6a7b0efc0565935701f7a3..07d7931e4810ab25aff8cbfc7f3cc969401240e4 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -3,19 +3,21 @@ (format! t "~%Using ASDF ~A~%" (asdf-version)) (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF -(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") -(def-test-system "fooey") -(defparameter *ticks* 0) -(defun tick () (incf *ticks*)) -(defsystem "foo") -(defmethod input-files :after ((o load-op) (c system)) (tick)) -(assert-equal *ticks* 0) -(input-files 'load-op "foo") -(assert-equal *ticks* 1) -(input-files 'load-op "foo") -(assert-equal *ticks* 1) ;; It was cached. -(assert (find-system "fooey" nil)) +(setf *asdf-session* nil) +(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") +(with-asdf-session (:override t) + (def-test-system "fooey") + (defparameter *ticks* 0) + (defun tick () (incf *ticks*)) + (defsystem "foo") + (defmethod input-files :after ((o load-op) (c system)) (tick)) + (assert-equal *ticks* 0) + (input-files 'load-op "foo") + (assert-equal *ticks* 1) + (input-files 'load-op "foo") + (assert-equal *ticks* 1) ;; It was cached. + (assert (find-system "fooey" nil))) (DBG "Try load ASDF with an empty configuration") (initialize-source-registry @@ -60,8 +62,7 @@ (clear-system "asdf") (with-asdf-session (:override t) - (with-expected-failure (#+xcl t) - ;; expected-failure: XCL has trouble with the ASDF upgrade + (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf)))) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index b9a63c3e895e9ae4a9485650428a19a2baf01d2f..d311894f79b38c6339dc97476a8c12224971ba9f 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -4,6 +4,7 @@ ;;; system that can be found using *system-definition-search-functions* (defun system-registered-time (name) (car (asdf::system-registered-p name))) +(setf (asdf-upgraded-p *asdf-session*) t) (defparameter test1.asd (nth-value 2 (locate-system :test1))) (assert-pathname-equal test1.asd (test-source "test1.asd")) diff --git a/test/test-try-refinding.script b/test/test-try-refinding.script index 227d5208c4729fcf60882824566ebe88c4acaed0..926accf40eb272eb4594838c2488c2adb8da62c4 100644 --- a/test/test-try-refinding.script +++ b/test/test-try-refinding.script @@ -2,6 +2,7 @@ ;;; test retrying finding location of an ASDF system. +(setf *asdf-session* nil) (in-package asdf-test) (defparameter *old-registry* asdf:*central-registry*) @@ -62,7 +63,7 @@ (DBG "After invoking restart, CENTRAL-REGISTRY is:" asdf:*central-registry*)) ;; avoid infinite looping - (leave-test 11 "Infinite loop while catching MISSING-COMPONENT")))) + (leave-test "Infinite loop while catching MISSING-COMPONENT" 11)))) (handler-bind ((asdf:missing-dependency-of-version #'(lambda (c)