Commit 56d84e7a authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.154: cache builtin-system-p for a big speedup.

We were checking it all the time in forced-p.
Also cache nil-pathname and root-pathname.
parent 1f4d6fec
......@@ -51,7 +51,7 @@
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(apply 'make-operation ,operation :original-initargs ,rest ,rest)
`(make-operation ,operation))
`(find-component () ,component))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args)
(if (typep ,component 'component)
......
......@@ -62,9 +62,13 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.153" ;; to be automatically updated by make bump-version
:version "2.26.154" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
#+asdf3 :builtin-system-p #+asdf3 t
:components
((:module "build"
:components
......
......@@ -102,6 +102,7 @@
(defun* parse-component-form (parent options &key previous-serial-component)
(destructuring-bind
(type name &rest rest &key
(builtin-system-p () bspp)
;; the following list of keywords is reproduced below in the
;; remove-plist-keys form. important to keep them in sync
components pathname perform explain output-files operation-done-p
......@@ -109,7 +110,7 @@
do-first if-component-dep-fails (version nil versionp)
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(declare (ignorable perform explain output-files operation-done-p builtin-system-p))
(check-component-input type name weakly-depends-on depends-on components)
(when (and parent
(find-component parent name)
......@@ -138,6 +139,8 @@
(setf component (apply 'make-instance (class-for-type parent type) args)))
(component-pathname component) ; eagerly compute the absolute pathname
(let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
(when (and (typep component 'system) (not bspp))
(setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir)))
(setf version (normalize-version version sysdir)))
(when (and versionp version (not (parse-version version nil)))
(warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
......
......@@ -340,19 +340,3 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(register-preloaded-system "asdf")
(register-preloaded-system "asdf-driver")
;;;; Beware of builtin systems
(defmethod builtin-system-p ((s system))
(or
;; For most purposes, asdf itself specially counts as builtin.
;; if you want to link it or do something forbidden to builtins,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
(equal "asdf" (coerce-name s))
;; Other builtin systems are those under the implementation directory
(let* ((system (find-system s nil))
(sysdir (and system (component-pathname system)))
(truesysdir (truename* sysdir))
(impdir (lisp-implementation-directory))
(trueimpdir (truename* impdir)))
(and sysdir impdir
(or (subpathp sysdir impdir)
(subpathp truesysdir trueimpdir))))))
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.153: Another System Definition Facility.
;;; This is ASDF 2.26.154: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -91,7 +91,9 @@
#:asdf-version
#:operation-error #:compile-failed #:compile-warned #:compile-error
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility
#:error-name
#:error-pathname
#:load-system-definition-error
......
......@@ -14,7 +14,8 @@
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
#:operating-system #:architecture #:lisp-version-string
#:hostname #:user-homedir #:lisp-implementation-directory
#:hostname #:user-homedir
#:lisp-implementation-directory #:lisp-implementation-pathname-p
#:getcwd #:chdir #:call-with-current-directory #:with-current-directory
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
......@@ -271,6 +272,16 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(truename* dir)
dir)))
(defun* lisp-implementation-pathname-p (pathname)
;; Other builtin systems are those under the implementation directory
(when pathname
(if-let (impdir (lisp-implementation-directory))
(or (subpathp pathname impdir)
(when *resolve-symlinks*
(if-let (truename (truename* pathname))
(if-let (trueimpdir (truename* impdir))
(subpathp truename trueimpdir))))))))
;;; Current directory
......
......@@ -32,7 +32,7 @@
#:pathname-root #:directory-separator-for-host
#:directorize-pathname-host-device
;; defaults
#:nil-pathname #:with-pathname-defaults
#:nil-pathname #:with-pathname-defaults #:*nil-pathname*
;; probe filesystem
#:truename* #:probe-file* #:safe-file-write-date
#:subdirectories #:directory-files #:directory*
......@@ -47,7 +47,8 @@
#:add-pathname-suffix #:tmpize-pathname
#:call-with-staging-pathname #:with-staging-pathname
;; physical pathnames
#:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname #:root-pathname
#:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname
#:root-pathname #:*root-pathname*
;; Windows shortcut support
#:read-null-terminated-string #:read-little-endian
#:parse-file-location-info #:parse-windows-shortcut
......@@ -357,8 +358,10 @@ Returns the (parsed) PATHNAME when true"
;; the default shouldn't matter, but we really want something physical
:defaults defaults))
(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
(defmacro with-pathname-defaults ((&optional defaults) &body body)
`(let ((*default-pathname-defaults* ,(or defaults '(nil-pathname)))) ,@body))
`(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))
(defun* truename* (p)
;; avoids both logical-pathname merging and physical resolution issues
......@@ -590,7 +593,7 @@ Any directory named .. is read as DOT-DOT,
which must be one of :BACK or :UP and defaults to :BACK.
HOST, DEVICE and VERSION components are taken from DEFAULTS,
which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL.
which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
No host or device can be specified in the string itself,
which makes it unsuitable for absolute pathnames outside Unix.
......@@ -627,7 +630,7 @@ to throw an error if the pathname is absolute"
(make-pathname*
:directory (unless file-only (cons relative path))
:name name :type type
:defaults (or defaults (nil-pathname)))
:defaults (or defaults *nil-pathname*))
(remove-plist-keys '(:type :dot-dot :defaults) keys))))))
(defun* unix-namestring (pathname)
......@@ -855,8 +858,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
#+clozure :if-exists #+clozure :rename-and-delete))
(defun* delete-file-if-exists (x)
(when (probe-file* x)
(delete-file x)))
(handler-case (delete-file x) (file-error () nil)))
;;; Translate a pathname
(defun* (translate-pathname*) (path absolute-source destination &optional root source)
......@@ -929,6 +931,7 @@ For the latter case, we ought pick random suffix and atomically open it."
Otherwise, this will be the root of some implementation-dependent filesystem host."
(sane-physical-pathname :keep :root :fallback t))
(defvar *root-pathname* (root-pathname))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
......
......@@ -19,7 +19,6 @@
(defgeneric* (find-system) (system &optional error-p))
(defgeneric* (system-source-file) (system)
(:documentation "Return the source file in which system is defined."))
(defgeneric* builtin-system-p (system))
(defgeneric* component-build-pathname (component))
(defgeneric* component-entry-point (component))
......@@ -44,6 +43,7 @@
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)
(builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
(build-pathname
:initform nil :initarg :build-pathname :accessor component-build-pathname)
(entry-point
......
......@@ -35,7 +35,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.153")
(asdf-version "2.26.154")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment