Commit 6876bde3 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.157: speed up pathname operations.

Optimize probe-file* in the case we do not care for truename.
Have truenamize iterate from pathname up to root rather than the other way,
to minimize the number of calls to truename.
Refactor pathname absolutization.
Shuffle functions around os, pathname, stream.
Shuffle functions around common-lisp, utility.
Remove root-pathname and sane-physical-pathname.
parent 6a4215d1
......@@ -42,7 +42,7 @@ XCL ?= xcl
# website, tag, install
header_lisp := header.lisp
driver_lisp := package.lisp common-lisp.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
driver_lisp := package.lisp common-lisp.lisp utility.lisp os.lisp pathname.lisp stream.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
......
......@@ -19,11 +19,11 @@ that you can't portably construct a complete program without using them."
(:file "package")
(:file "common-lisp" :depends-on ("package"))
(:file "utility" :depends-on ("common-lisp"))
(:file "pathname" :depends-on ("utility"))
(:file "os" :depends-on ("utility"))
(:file "pathname" :depends-on ("os"))
(:file "stream" :depends-on ("pathname"))
(:file "os" :depends-on ("stream"))
(:file "image" :depends-on ("os"))
(:file "run-program" :depends-on ("os"))
(:file "image" :depends-on ("stream"))
(:file "run-program" :depends-on ("stream"))
(:file "lisp-build" :depends-on ("image"))
(:file "configuration" :depends-on ("image"))
(:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration"))
......
......@@ -62,7 +62,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.156" ;; to be automatically updated by make bump-version
:version "2.26.157" ;; 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.
......
......@@ -70,7 +70,7 @@ if that's whay you mean." ;;)
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
(subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
(map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(source-to-target-mappings nil)
......@@ -89,7 +89,7 @@ if that's whay you mean." ;;)
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
(cdr (pathname-directory (user-homedir-pathname))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
......
......@@ -12,6 +12,7 @@
(:reexport :common-lisp)
(:recycle :asdf/common-lisp :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
#+cormanlisp
(:export
#:logical-pathname #:translate-logical-pathname
......@@ -50,6 +51,9 @@
(deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*)
(defun translate-logical-pathname (x) x)
(defun user-homedir-pathname (&optional host)
(declare (ignore host))
(parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
(defun file-namestring (p)
(setf p (pathname p))
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
......@@ -133,23 +137,40 @@
(setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
;;;; compatfmt: avoid fancy format directives when unsupported
;;;; Looping
(defmacro loop* (&rest rest)
#-genera `(loop ,@rest)
#+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun strcat (&rest strings)
(apply 'concatenate 'string strings)))
(defun remove-substrings (substrings string)
(let ((length (length string)) (stream nil))
(labels ((emit (start end)
(when (and (zerop start) (= end length))
(return-from remove-substrings string))
(unless stream (setf stream (make-string-output-stream)))
(write-string string stream :start start :end end))
(recurse (substrings start end)
(cond
((= start end))
((null substrings) (emit start end))
(t (let* ((sub (first substrings))
(found (search sub string))
(more (rest substrings)))
(cond
(found
(recurse more start found)
(recurse more (+ found (length sub)) end))
(t
(recurse more start end))))))))
(recurse substrings 0 length))
(if stream (get-output-stream-string stream) ""))))
(defmacro compatfmt (format)
#+(or gcl genera)
(loop* :for (unsupported . replacement)
:in (append
'(("~3i~_" . ""))
#+(or genera gcl2.6) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
(loop :for found = (search unsupported format) :while found :do
(setf format (strcat (subseq format 0 found) replacement
(subseq format (+ found (length unsupported)))))))
format)
(remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
#-(or gcl genera) format)
......@@ -49,7 +49,7 @@
,@(when (os-windows-p)
`(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
,(subpathname (user-homedir) ".config/common-lisp/"))))
,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
(remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
:from-end t :test 'equal)))
......@@ -227,12 +227,13 @@ directive.")
(return-from resolve-absolute-location
(let ((p (make-pathname* :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :home) (user-homedir-pathname))
((eql :here) (resolve-absolute-location
*here-directory* :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
:resolve-symlinks *resolve-symlinks*
:want-absolute t))
;; Try to override declaration in previous versions of ASDF.
......@@ -241,21 +242,20 @@ directive.")
(defun* (resolve-location) (x &key ensure-directory wilden directory)
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(let ((dirp (or directory ensure-directory)))
(if (atom x)
(resolve-absolute-location x :ensure-directory dirp :wilden wilden)
(loop* :with (first . rest) = x
:with path = (resolve-absolute-location
first :ensure-directory (and (or dirp rest) t)
:wilden (and wilden (null rest)))
:for (element . morep) :on rest
:for dir = (and (or morep dirp) t)
:for wild = (and wilden (not morep))
:do (setf path (merge-pathnames*
(resolve-relative-location
element :ensure-directory dir :wilden wild)
path))
:finally (return path)))))
(loop* :with dirp = (or directory ensure-directory)
:with (first . rest) = (if (atom x) (list x) x)
:with path = (resolve-absolute-location
first :ensure-directory (and (or dirp rest) t)
:wilden (and wilden (null rest)))
:for (element . morep) :on rest
:for dir = (and (or morep dirp) t)
:for wild = (and wilden (not morep))
:for sub = (merge-pathnames*
(resolve-relative-location
element :ensure-directory dir :wilden wild)
path)
:do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
:finally (return path)))
(defun* location-designator-p (x)
(flet ((absolute-component-p (c)
......
......@@ -31,13 +31,12 @@
;; and may be from within the EVAL-WHEN of a file compilation.
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(let ((pathname (parse-unix-namestring pathname :type :directory))
(load-pathname (load-pathname)))
(when (or pathname load-pathname)
(pathname-directory-pathname
(absolutize-pathnames
(list pathname load-pathname *default-pathname-defaults* (getcwd))
:resolve-symlinks *resolve-symlinks*)))))
(resolve-symlinks*
(ensure-pathname-absolute
(parse-unix-namestring pathname :type :directory)
#'(lambda () (ensure-pathname-absolute
(load-pathname) 'get-pathname-defaults nil))
nil)))
;;; Component class
......
......@@ -156,14 +156,13 @@ Going forward, we recommend new users should be using the source-registry.
(defun* probe-asd (name defaults &key truename)
(block nil
(when (directory-pathname-p defaults)
(let* ((file (probe-file*
(absolutize-pathnames
(list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults* (getcwd))
:resolve-symlinks truename)
:truename truename)))
(when file
(return file)))
(if-let (file (probe-file*
(ensure-pathname-absolute
(parse-unix-namestring name :type "asd")
#'(lambda () (ensure-pathname-absolute defaults 'get-pathname-defaults nil))
nil)
:truename truename))
(return file))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (os-windows-p)
(let ((shortcut
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.156: Another System Definition Facility.
;;; This is ASDF 2.26.157: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -318,4 +318,5 @@ if we are not called from a directly executable image."
;;; Some universal image restore hooks
(map () 'register-image-restore-hook
'(setup-temporary-directory setup-stderr setup-command-line-arguments))
'(setup-temporary-directory setup-stderr setup-command-line-arguments
#+abcl detect-os))
This diff is collapsed.
This diff is collapsed.
......@@ -160,11 +160,11 @@ system names to pathnames of .asd files")
#+scl (:tree #p"file://modules/")))
(defun* default-source-registry ()
`(:source-registry
#+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
#+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
,@(loop :for dir :in
`(,@(when (os-unix-p)
`(,(or (getenv-absolute-directory "XDG_DATA_HOME")
(subpathname (user-homedir) ".local/share/"))
(subpathname (user-homedir-pathname) ".local/share/"))
,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
'("/usr/local/share" "/usr/share"))))
,@(when (os-windows-p)
......
......@@ -3,7 +3,7 @@
(asdf/package:define-package :asdf/stream
(:recycle :asdf/stream)
(:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname)
(:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname)
(:export
#:*default-stream-element-type* #:*stderr* #:setup-stderr
#:with-safe-io-syntax #:call-with-safe-io-syntax
......@@ -18,7 +18,15 @@
#:eval-input #:eval-thunk #:standard-eval-thunk
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*))
#:*default-encoding* #:*utf-8-external-format*
#:ensure-all-directories-exist
#:rename-file-overwriting-target
#:delete-file-if-exists
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
#:call-with-temporary-file #:with-temporary-file
#:add-pathname-suffix #:tmpize-pathname
#:call-with-staging-pathname #:with-staging-pathname))
(in-package :asdf/stream)
(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
......@@ -351,3 +359,115 @@ and implementation-defined external-format's")
(defun* encoding-external-format (encoding)
(funcall *encoding-external-format-hook* encoding))
;;; Simple filesystem operations
(defun* ensure-all-directories-exist (pathnames)
(dolist (pathname pathnames)
(ensure-directories-exist (translate-logical-pathname pathname))))
(defun* rename-file-overwriting-target (source target)
#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
(posix:copy-file source target :method :rename)
#-clisp
(rename-file source target
#+clozure :if-exists #+clozure :rename-and-delete))
(defun* delete-file-if-exists (x)
(handler-case (delete-file x) (file-error () nil)))
;;; Using temporary files
(defun* default-temporary-directory ()
(or
(when (os-unix-p)
(or (getenv-pathname "TMPDIR" :ensure-directory t)
(parse-native-namestring "/tmp/")))
(when (os-windows-p)
(getenv-pathname "TEMP" :ensure-directory t))
(subpathname (user-homedir-pathname) "tmp/")))
(defvar *temporary-directory* nil)
(defun* temporary-directory ()
(or *temporary-directory* (default-temporary-directory)))
(defun setup-temporary-directory ()
(setf *temporary-directory* (default-temporary-directory))
;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
#+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
(defun* call-with-temporary-file
(thunk &key
prefix keep (direction :io)
(element-type *default-stream-element-type*)
(external-format :default))
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
:with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
:for counter :from (random (ash 1 32))
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
;; TODO: on Unix, do something about umask
;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
(with-open-file (stream pathname
:direction direction
:element-type element-type
#-gcl2.6 :external-format #-gcl2.6 external-format
:if-exists nil :if-does-not-exist :create)
(when stream
(return
(if keep
(funcall thunk stream pathname)
(unwind-protect
(funcall thunk stream pathname)
(ignore-errors (delete-file pathname)))))))))
(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
(pathname (gensym "PATHNAME") pathnamep)
prefix keep direction element-type external-format)
&body body)
"Evaluate BODY where the symbols specified by keyword arguments
STREAM and PATHNAME are bound corresponding to a newly created temporary file
ready for I/O. Unless KEEP is specified, delete the file afterwards."
(check-type stream symbol)
(check-type pathname symbol)
`(flet ((think (,stream ,pathname)
,@(unless pathnamep `((declare (ignore ,pathname))))
,@(unless streamp `((when ,stream (close ,stream))))
,@body))
#-gcl (declare (dynamic-extent #'think))
(call-with-temporary-file
#'think
,@(when direction `(:direction ,direction))
,@(when prefix `(:prefix ,prefix))
,@(when keep `(:keep ,keep))
,@(when element-type `(:element-type ,element-type))
,@(when external-format `(:external-format external-format)))))
;;; Temporary pathnames
(defun* add-pathname-suffix (pathname suffix)
(make-pathname :name (strcat (pathname-name pathname) suffix)
:defaults pathname))
(defun* tmpize-pathname (x)
(add-pathname-suffix x "-ASDF-TMP"))
(defun* call-with-staging-pathname (pathname fun)
"Calls fun with a staging pathname, and atomically
renames the staging pathname to the pathname in the end.
Note: this protects only against failure of the program,
not against concurrent attempts.
For the latter case, we ought pick random suffix and atomically open it."
(let* ((pathname (pathname pathname))
(staging (tmpize-pathname pathname)))
(unwind-protect
(multiple-value-prog1
(funcall fun staging)
(rename-file-overwriting-target staging pathname))
(delete-file-if-exists staging))))
(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
......@@ -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.156")
(asdf-version "2.26.157")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))
......
......@@ -5,9 +5,9 @@
(:recycle :asdf/utility :asdf)
(:use :asdf/common-lisp :asdf/package)
;; import and reexport a few things defined in :asdf/common-lisp
(:import-from :asdf/common-lisp #:strcat #:compatfmt #:loop*
(:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export #:nil #:strcat #:compatfmt #:loop*
(:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export
;; magic helper to define debugging functions:
......@@ -16,7 +16,7 @@
#:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
#:emptyp ;; sequences
#:first-char #:last-char #:split-string ;; strings
#:strcat #:first-char #:last-char #:split-string ;; strings
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
......@@ -163,6 +163,8 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Strings
(defun* strcat (&rest strings)
(apply 'concatenate 'string strings))
(defun* first-char (s)
(and (stringp s) (plusp (length s)) (char s 0)))
......@@ -404,3 +406,4 @@ or a string describing the format-control of a simple-condition."
(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
`(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
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