From 32a579df0e942ab7a71a40250f26c171b405d8be Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Fri, 15 May 2020 23:44:44 -0400 Subject: [PATCH] Ensure upgradability without DEFUN* --- action.lisp | 2 +- output-translations.lisp | 4 ++-- parse-defsystem.lisp | 7 +++--- plan.lisp | 8 +++---- source-registry.lisp | 4 ++-- system.lisp | 11 +++++---- uiop/configuration.lisp | 2 +- uiop/lisp-build.lisp | 2 +- uiop/pathname.lisp | 2 +- uiop/utility.lisp | 49 ++++++++++++++++++++++------------------ upgrade.lisp | 26 ++++++++++++++------- 11 files changed, 67 insertions(+), 50 deletions(-) diff --git a/action.lisp b/action.lisp index 384df556b..e47c1b6b3 100644 --- a/action.lisp +++ b/action.lisp @@ -132,7 +132,7 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/" ;;;; Detection of circular dependencies (with-upgradability () - (defun (action-valid-p) (operation component) + (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. diff --git a/output-translations.lisp b/output-translations.lisp index 7ea330d5d..d2512ba01 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -194,7 +194,7 @@ and the order is by decreasing length of namestring of the source pathname.") (when inherit (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - (defun* (process-output-translations-directive) (directive &key inherit collect) + (defun process-output-translations-directive (directive &key inherit collect) (if (atom directive) (ecase directive ((:enable-user-cache) @@ -287,7 +287,7 @@ effectively disabling the output translation facility." ;; Top-level entry-point to _use_ output-translations - (defun* (apply-output-translations) (path) + (defun apply-output-translations (path) (etypecase path (logical-pathname path) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index a45868603..19c986d7d 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -148,7 +148,8 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ ;; Given a form used as :version specification, in the context of a system definition ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form ;; to an acceptable ASDF-format version. - (defun* (normalize-version) (form &key pathname component parent) + (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31 + (defun normalize-version (form &key pathname component parent) (labels ((invalid (&optional (continuation "using NIL instead")) (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>") form component parent pathname continuation)) @@ -293,11 +294,11 @@ COMPONENTS is a list of the explicitly defined children descriptions. SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous children.")) - (defun* stable-union (s1 s2 &key (test #'eql) (key 'identity)) + (defun stable-union (s1 s2 &key (test #'eql) (key 'identity)) (append s1 (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2))) - (defun* (parse-component-form) (parent options &key previous-serial-components) + (defun (parse-component-form) (parent options &key previous-serial-components) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) diff --git a/plan.lisp b/plan.lisp index e9a963e51..af67363ff 100644 --- a/plan.lisp +++ b/plan.lisp @@ -224,7 +224,7 @@ 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) (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) @@ -234,7 +234,7 @@ to be meaningful, or could it just as well have been done in another Lisp image? :when (action-valid-p dep-o dep-c) :do (funcall fun dep-o dep-c)))) - (defun* (reduce-direct-dependencies) (operation component combinator seed) + (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." @@ -243,7 +243,7 @@ initialized with SEED." #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) seed) - (defun* (direct-dependencies) (operation component) + (defun direct-dependencies (operation component) "Compute a list of the direct dependencies of the action within the plan" (reverse (reduce-direct-dependencies operation component #'acons nil))) @@ -527,7 +527,7 @@ Update the VISITED-ACTIONS table with the known status, but don't add anything t :do (collect-action-dependencies plan (action-operation action) (action-component action))) (plan-actions plan))) - (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) + (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." (with-asdf-session (:override t) diff --git a/source-registry.lisp b/source-registry.lisp index 60001022e..a086cc88a 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -233,11 +233,11 @@ after having found a .asd file? True by default.") (defgeneric process-source-registry (spec &key inherit register)) - (defun* (inherit-source-registry) (inherit &key register) + (defun inherit-source-registry (inherit &key register) (when inherit (process-source-registry (first inherit) :register register :inherit (rest inherit)))) - (defun* (process-source-registry-directive) (directive &key inherit register) + (defun process-source-registry-directive (directive &key inherit register) (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) (ecase kw ((:include) diff --git a/system.lisp b/system.lisp index 31ff92b07..b05888405 100644 --- a/system.lisp +++ b/system.lisp @@ -186,10 +186,11 @@ the primary one." (slot-value (find-system (primary-system-name system)) slot-name)))) (defmacro define-system-virtual-slot-reader (slot-name) - `(defun* ,(intern (concatenate 'string (string :system-) - (string slot-name))) - (system) - (system-virtual-slot-value system ',slot-name))) + (let ((name (intern (strcat (string :system-) (string slot-name))))) + `(progn + (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11 + (declaim (notinline ,name)) + (defun ,name (system) (system-virtual-slot-value system ',slot-name))))) (defmacro define-system-virtual-slot-readers () `(progn ,@(mapcar (lambda (slot-name) `(define-system-virtual-slot-reader ,slot-name)) @@ -214,7 +215,7 @@ the primary one." in which the system specification (.asd file) is located." (pathname-directory-pathname (system-source-file system-designator))) - (defun* (system-relative-pathname) (system name &key type) + (defun system-relative-pathname (system name &key type) "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, return the absolute pathname of a corresponding file under that system's source code pathname." (subpathname (system-source-directory system) name :type type)) diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp index 0d6524007..ba68db762 100644 --- a/uiop/configuration.lisp +++ b/uiop/configuration.lisp @@ -215,7 +215,7 @@ directive.") (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) (:ensure-directory boolean)) t) resolve-location)) - (defun* (resolve-location) (x &key ensure-directory wilden directory) + (defun resolve-location (x &key ensure-directory wilden directory) "Resolve location designator X into a PATHNAME" ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory (loop :with dirp = (or directory ensure-directory) diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index 12870ba38..557fae188 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -662,7 +662,7 @@ possibly in a different process. Otherwise just call THUNK." (defvar *compile-check* nil "A hook for user-defined compile-time invariants") - (defun* (compile-file*) (input-file &rest keys + (defun compile-file* (input-file &rest keys &key (compile-check *compile-check*) output-file warnings-file #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl &allow-other-keys) diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 23fb20661..1daf98cc2 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -715,7 +715,7 @@ added to its DIRECTORY component. This is useful for output translations." :defaults pathname))) pathname))) - (defun* (translate-pathname*) (path absolute-source destination &optional root source) + (defun translate-pathname* (path absolute-source destination &optional root source) "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. PATH is the pathname to be translated. ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, diff --git a/uiop/utility.lisp b/uiop/utility.lisp index c985e776a..071e6bb7a 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -12,7 +12,6 @@ ;; magic helper to define debugging functions: #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:with-upgradability ;; (un)defining functions in an upgrade-friendly way - #:defun* #:defgeneric* #:nest #:if-let ;; basic flow control #:parse-body ;; macro definition helper #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists @@ -41,27 +40,33 @@ (in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: -;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, -;; thus replacing the function without warning or error -;; even if the signature and/or generic-ness of the function has changed. -;; For a generic function, this invalidates any previous DEFMETHOD. +;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE, +;; so that new definitions are always seen by all callers, even those up the stack. +;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state +;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file. +;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it. +;; - THOU SHALT change the name of a function whenever thou makest an incompatible change. +;; - For instance, when the meanings of NIL and T for timestamps was inverted, +;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc., +;; because the change other caused a huge incompatibility during upgrade. +;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc., +;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND. +;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that +;; all the methods required for ASDF to successfully continue compiling itself +;; shall be defined in the same file as the one with the FMAKUNBOUND. +;; - When a function goes from DEFGENERIC to DEFUN, you MAY have to use FMAKUNBOUND, too. +;; Please try the upgrade tests on all supported implementations and update this comment afterwards. +;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC, +;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN). +;; - Any time you change a signature, please keep a comment specifying the first release after the change; +;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND. (eval-when (:load-toplevel :compile-toplevel :execute) - (defun frob-defun/defgeneric (form) - (assert (member (first form) '(defun defgeneric))) - (let ((name (second form))) - (destructuring-bind (name &key (supersede t)) - (if (or (atom name) (eq (car name) 'setf)) - (list name :supersede nil) - name) - (declare (ignorable supersede)) - `(progn - ;; We usually try to do it only for the functions that need it, - ;; which happens in asdf/upgrade - however, for ECL, we need this hammer. - ,@(when supersede - `((fmakunbound ',name))) - ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl - `((declaim (notinline ,name)))) - ,form)))) + (defun ensure-function-notinline (definition &aux (name (second definition))) + (assert (member (first definition) '(defun defgeneric))) + `(progn + ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL + `(declaim (notinline ,name))) + ,definition)) (defmacro with-upgradability ((&optional) &body body) "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified to also declare the functions NOTINLINE and to accept a wrapping the function name @@ -72,7 +77,7 @@ to supersede any previous definition." ,@(loop :for form :in body :collect (if (consp form) (case (first form) - ((defun defgeneric) (frob-defun/defgeneric form)) + ((defun defgeneric) (ensure-function-notinline form)) (otherwise form)) form))))) diff --git a/upgrade.lisp b/upgrade.lisp index 9eb6a2e8a..e2cc4d6ca 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -108,18 +108,28 @@ previously-loaded version of ASDF." (when-upgrading () (let* ((previous-version (first *previous-asdf-versions*)) (redefined-functions ;; List of functions that changed incompatibly since 2.27: - ;; gf signature changed (should NOT happen), defun that became a generic function, - ;; method removed that will mess up with new ones (especially :around :before :after, - ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. + ;; gf signature changed (should NOT happen), defun that became a generic function or + ;; the other way around, method removed that will mess up with new ones + ;; (especially :around :before :after, more specific or call-next-method'ed method) + ;; and/or semantics otherwise modified. Oops. ;; NB: it's too late to do anything about functions in UIOP! - ;; If you introduce some critical incompatibility there, you must change the function name. + ;; If you introduce some critical incompatibility there, you MUST change the function name. ;; Note that we don't need do anything about functions that changed incompatibly ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. - ;; Also note that we don't include the defgeneric=>defun, because they are - ;; done directly with defun* and need not trigger a punt on data. ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 - `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 - ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) + ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141 + `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key + ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 + ,@(when (version< previous-version "3.1.7.20") '(#:find-component)) + ,@(when (version< previous-version "3.2.0") '(#:required-components)) ; was a gf + ,@(when (version< previous-version "3.3.0") + '(#:action-valid-p #:map-direct-dependencies ;; were gfs with plan first + #:reduce-direct-dependencies #:direct-dependencies)) + ,@(when (version< previous-version "3.3.2.11") ;; were gfs + '(#:system-long-name #:system-description #:system-long-description + #:system-author #:system-maintainer #:system-mailto + #:system-homepage #:system-source-control + #:system-licence #:system-license #:system-version #:system-bug-tracker)))) (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork -- GitLab