From 84e17ea087a1707eb96d36f3ce7e0d8d1de73b69 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 20 Mar 2014 13:17:34 -0400 Subject: [PATCH] Fold *systems-being-defined* into the *asdf-cache*. Add regression test for no infinite loop when processing asd files that mutually define each other's systems. (Prompted by Robert Strandh inquiring about the bug fixed in 2.015.[23] after my mentioning an infinite loop in my ASDF3 article.) Checked that removing the set-asdf-cache-entry in parse-defsystem triggers the bug. --- cache.lisp | 17 +++--- find-system.lisp | 83 +++++++++++----------------- interface.lisp | 2 +- operate.lisp | 12 ++-- parse-defsystem.lisp | 8 +-- test/test-mutual-redefinition-1.asd | 2 + test/test-mutual-redefinition-2.asd | 2 + test/test-mutual-redefinition.script | 33 +++++++++++ 8 files changed, 89 insertions(+), 70 deletions(-) create mode 100644 test/test-mutual-redefinition-1.asd create mode 100644 test/test-mutual-redefinition-2.asd create mode 100644 test/test-mutual-redefinition.script diff --git a/cache.lisp b/cache.lisp index 4ca218f4..729a184e 100644 --- a/cache.lisp +++ b/cache.lisp @@ -4,7 +4,7 @@ (uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring + #:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) (in-package :asdf/cache) @@ -33,14 +33,15 @@ (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) - (defun call-with-asdf-cache (thunk &key override) - (if (and *asdf-cache* (not override)) - (funcall thunk) - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (funcall thunk)))) + (defun call-with-asdf-cache (thunk &key override key) + (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) + (if (and *asdf-cache* (not override)) + (funcall fun) + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (funcall fun))))) - (defmacro with-asdf-cache ((&key override) &body body) - `(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) + (defmacro with-asdf-cache ((&key key override) &body body) + `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* diff --git a/find-system.lisp b/find-system.lisp index 564d1350..897eb995 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -4,18 +4,18 @@ (uiop/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system :asdf/cache) + :asdf/cache :asdf/component :asdf/system) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename - #:find-system #:locate-system #:load-asd #:with-system-definitions + #:find-system #:locate-system #:load-asd #:system-registered-p #:register-system #: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 - #:find-system-if-being-defined #:*systems-being-defined* + #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* @@ -254,32 +254,13 @@ Going forward, we recommend new users should be using the source-registry. (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) - (defvar *systems-being-defined* nil - "A hash-table of systems currently being defined keyed by name, or NIL") - (defun find-system-if-being-defined (name) - (when *systems-being-defined* - ;; notable side effect: mark the system as being defined, to avoid infinite loops - (ensure-gethash (coerce-name name) *systems-being-defined* nil))) - - (defun call-with-system-definitions (thunk) - (if *systems-being-defined* - (call-with-asdf-cache thunk) - (let ((*systems-being-defined* (make-hash-table :test 'equal))) - (call-with-asdf-cache thunk)))) - - (defun clear-systems-being-defined () - (when *systems-being-defined* - (clrhash *systems-being-defined*))) - - (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined) - - (defmacro with-system-definitions ((&optional) &body body) - `(call-with-system-definitions #'(lambda () ,@body))) + ;; notable side effect: mark the system as being defined, to avoid infinite loops + (values (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. - (with-system-definitions () + (with-asdf-cache () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) ;; Note that our backward-compatible *readtable* is @@ -374,41 +355,41 @@ PATHNAME when not null is a path from where to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time))) + (with-asdf-cache (:key `(locate-system ,name)) + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) + (values foundp found-system pathname previous previous-time)))) (defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () + (with-asdf-cache (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) - (unless (or (equal name primary-name) - (nth-value 1 (gethash primary-name *systems-being-defined*))) + (unless (equal name primary-name) (find-system primary-name nil))) (loop (restart-case (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (when (and found-system (eq found-system previous) - (or (gethash name *systems-being-defined*) + (or (gethash `(find-system ,name) *asdf-cache*) (and *immutable-systems* (gethash name *immutable-systems*)))) (return found-system)) (assert (eq foundp (and (or found-system pathname previous) t))) diff --git a/interface.lisp b/interface.lisp index 8f31c644..ce844ebc 100644 --- a/interface.lisp +++ b/interface.lisp @@ -18,7 +18,7 @@ (:export #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name #:oos #:operate #:make-plan #:perform-plan #:sequential-plan - #:system-definition-pathname #:with-system-definitions + #:system-definition-pathname #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:load-systems* #:require-system #:test-system #:clear-system diff --git a/operate.lisp b/operate.lisp index 79ac3f8e..4e040d58 100644 --- a/operate.lisp +++ b/operate.lisp @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export @@ -75,7 +75,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: :original-initargs operation-initargs operation-initargs) component-path keys)))) ;; Setup proper bindings around any operate call. - (with-system-definitions () + (with-asdf-cache () (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) (*compile-file-failure-behaviour* on-failure)) @@ -209,11 +209,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (with-upgradability () (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. - (when *systems-being-defined* - (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) - (clrhash *systems-being-defined*) + (when *asdf-cache* + (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache* + :when (eq x 'find-system) :collect y))) + (clrhash *asdf-cache*) (dolist (s l) (find-system s nil))))) - (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 2cf2b02c..75d911b9 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -5,7 +5,7 @@ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares (:use :uiop/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/cache + :asdf/cache :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/backward-internals) (:import-from :asdf/system #:depends-on #:weakly-depends-on) @@ -245,8 +245,8 @@ system names contained using COERCE-NAME. Return the result." ;; of the same name to reuse options (e.g. pathname) from. ;; To avoid infinite recursion in cases where you defsystem a system ;; that is registered to a different location to find-system, - ;; we also need to remember it in a special variable *systems-being-defined*. - (with-system-definitions () + ;; we also need to remember it in the asdf-cache. + (with-asdf-cache () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (registered (system-registered-p name)) @@ -265,7 +265,7 @@ system names contained using COERCE-NAME. Return the result." (setf component-options (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on)) component-options))) - (setf (gethash name *systems-being-defined*) system) + (set-asdf-cache-entry `(find-system ,name) (list system)) (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. diff --git a/test/test-mutual-redefinition-1.asd b/test/test-mutual-redefinition-1.asd new file mode 100644 index 00000000..1e74af0e --- /dev/null +++ b/test/test-mutual-redefinition-1.asd @@ -0,0 +1,2 @@ +(defsystem test-mutual-redefinition-1) +(defsystem test-mutual-redefinition-2) diff --git a/test/test-mutual-redefinition-2.asd b/test/test-mutual-redefinition-2.asd new file mode 100644 index 00000000..1e74af0e --- /dev/null +++ b/test/test-mutual-redefinition-2.asd @@ -0,0 +1,2 @@ +(defsystem test-mutual-redefinition-1) +(defsystem test-mutual-redefinition-2) diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script new file mode 100644 index 00000000..4f66c467 --- /dev/null +++ b/test/test-mutual-redefinition.script @@ -0,0 +1,33 @@ +;;-*- Lisp -*- + +(load-system 'test-mutual-redefinition-1) +(defun current-system-source-file (x) + (system-source-file (cdr (gethash x asdf/find-system:*defined-systems*)))) + +(with-asdf-cache () + (DBG "loading test-mutual-redefinition-1") + (assert-pathname-equal + (test-source "test-mutual-redefinition-1.asd") + (current-system-source-file "test-mutual-redefinition-1")) + (assert-pathname-equal + (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") + (load-system 'test-mutual-redefinition-2) + (assert-pathname-equal + (test-source "test-mutual-redefinition-1.asd") + (current-system-source-file "test-mutual-redefinition-1")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-1.asd") + (current-system-source-file "test-mutual-redefinition-2")) + + (with-asdf-cache (:override t) + (DBG "loading test-mutual-redefinition-2 in a different cache session") + (load-system 'test-mutual-redefinition-2) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-1")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")))) -- GitLab