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

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." ;;)
(centralize-lisp-binaries nil)
(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
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
(cdr (pathname-directory (user-homedir-pathname))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
......@@ -12,6 +12,7 @@
(:reexport :common-lisp)
(:recycle :asdf/common-lisp :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
#: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)
((= start end))
((null substrings) (emit start end))
(t (let* ((sub (first substrings))
(found (search sub string))
(more (rest substrings)))
(recurse more start found)
(recurse more (+ found (length sub)) end))
(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)))))))
(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*
element :ensure-directory dir :wilden wild)
: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*
element :ensure-directory dir :wilden wild)
: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)
(list pathname load-pathname *default-pathname-defaults* (getcwd))
:resolve-symlinks *resolve-symlinks*)))))
(parse-unix-namestring pathname :type :directory)
#'(lambda () (ensure-pathname-absolute
(load-pathname) 'get-pathname-defaults 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*
(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*
(parse-unix-namestring name :type "asd")
#'(lambda () (ensure-pathname-absolute defaults 'get-pathname-defaults 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 <>.
......@@ -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))
......@@ -3,23 +3,17 @@
(asdf/package:define-package :asdf/os
(:recycle :asdf/os :asdf)
(:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream)
(:use :asdf/common-lisp :asdf/package :asdf/utility)
#:featurep #:os-unix-p #:os-windows-p ;; features
#:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
#:getenv #:getenvp ;; environment variables
#:native-namestring #:parse-native-namestring
#:inter-directory-separator #:split-native-pathnames-string
#:getenv-pathname #:getenv-pathnames
#:getenv-absolute-directory #:getenv-absolute-directories
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
#:operating-system #:architecture #:lisp-version-string
#: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
#:call-with-temporary-file #:with-temporary-file))
#:hostname #:getcwd #:chdir
;; Windows shortcut support
#:read-null-terminated-string #:read-little-endian
#:parse-file-location-info #:parse-windows-shortcut))
(in-package :asdf/os)
;;; Features
......@@ -33,21 +27,23 @@
(t (error "Malformed feature specification ~S" x))))
(defun* os-unix-p ()
(featurep '(:or :unix :cygwin :darwin)))
(or #+abcl (featurep :unix)
#+(and (not abcl) (or unix cygwin darwin)) t))
(defun* os-windows-p ()
(and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
(or #+abcl (featurep :windows)
#+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
(defun* os-genera-p ()
(featurep :genera))
(or #+genera t))
(defun* detect-os ()
(flet ((yes (yes) (pushnew yes *features*))
(no (no) (setf *features* (remove no *features*))))
((os-unix-p) (yes :os-unix) (no :os-windows))
((os-windows-p) (yes :os-windows) (no :os-unix))
((os-genera-p) (no :os-unix) (no :os-windows))
((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
(t (error "Congratulations for trying XCVB on an operating system~%~
that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
......@@ -89,62 +85,6 @@ then returning the non-empty string value of the variable"
(let ((g (getenv x))) (and (not (emptyp g)) g)))
;;; Native vs Lisp syntax
(defun* native-namestring (x)
"From a CL pathname, a return namestring suitable for passing to the operating system"
(when x
(let ((p (pathname x)))
#+clozure (with-pathname-defaults ((root-pathname))
(ccl:native-translated-namestring p)) ; see ccl bug 978
#+(or cmu scl) (ext:unix-namestring p nil)
#+sbcl (sb-ext:native-namestring p)
#-(or clozure cmu sbcl scl)
(if (os-unix-p) (unix-namestring p)
(namestring p)))))
(defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
"From a native namestring suitable for use by the operating system, return
a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(check-type string (or string null))
(let* ((pathname
(when string
(with-pathname-defaults ((root-pathname))
#+clozure (ccl:native-to-pathname string)
#+sbcl (sb-ext:parse-native-namestring string)
#-(or clozure sbcl)
(if (os-unix-p)
(parse-unix-namestring string :ensure-directory ensure-directory)
(parse-namestring string)))))
(if ensure-directory
(and pathname (ensure-directory-pathname pathname))
(apply 'ensure-pathname pathname constraints)))
;;; Native pathnames in environment
(defun* inter-directory-separator ()
(if (os-unix-p) #\: #\;))
(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
(apply 'parse-native-namestring (getenvp x)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
(apply 'split-native-pathnames-string (getenvp x)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
(defun* getenv-absolute-directory (x)
(getenv-pathname x :want-absolute t :ensure-directory t))
(defun* getenv-absolute-directories (x)
(getenv-pathnames x :want-absolute t :ensure-directory t))
;;;; implementation-identifier
;; produce a string to identify current implementation.
......@@ -252,153 +192,112 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
#+clisp (first (split-string (machine-instance) :separator " "))
#+gcl (system:gethostname))
(defun* user-homedir ()
#+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
#+mcl (current-user-homedir-pathname)
#-(or cormanlisp mcl) (user-homedir-pathname))))
(defun* lisp-implementation-directory (&key truename)
(let ((dir
#+clozure #p"ccl:"
#+(or ecl mkcl) #p"SYS:"
#+gcl system::*system-directory*
#+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
(funcall it)
(getenv-pathname "SBCL_HOME" :ensure-directory t)))))
(if (and dir truename)
(truename* dir)
(defun* lisp-implementation-pathname-p (pathname)
;; Other builtin systems are those under the implementation directory
(and (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
(defun* getcwd ()
"Get the current working directory as per POSIX getcwd(3), as a pathname object"
(or #+abcl (parse-native-namestring
(or #+abcl (parse-namestring
(java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
#+allegro (excl::current-directory)
#+clisp (ext:default-directory)
#+clozure (ccl:current-directory)
#+(or cmu scl) (parse-native-namestring
#+(or cmu scl) (ext:parse-unix-namestring
(nth-value 1 (unix:unix-current-directory)) :ensure-directory t)
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
#+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way?
#+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
(first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
#+sbcl (parse-native-namestring (sb-unix:posix-getcwd/))
#+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
#+xcl (extensions:current-directory)
(error "getcwd not supported on your implementation")))
(defun* chdir (x)
"Change current directory, as per POSIX chdir(2)"
#-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x)))
(or #+clisp (ext:cd x)
#+clozure (setf (ccl:current-directory) x)
#+cormanlisp (unless (zerop (win32::_chdir x))
#+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
(error "Could not set current directory to ~A" x))
#+sbcl (symbol-call :sb-posix :chdir x)
#+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
(error "chdir not supported on your implementation")))
(defun* call-with-current-directory (dir thunk)
(if dir
(let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir))))
(*default-pathname-defaults* dir)
(cwd (getcwd)))
(chdir dir)
(funcall thunk)
(chdir cwd)))
(funcall thunk)))
(defmacro with-current-directory ((dir) &body body)
"Call BODY while the POSIX current working directory is set to DIR"
`(call-with-current-directory ,dir #'(lambda () ,@body)))
;;; Using temporary files
(defun* default-temporary-directory ()
(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) "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))
: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
(if keep
(funcall thunk stream pathname)
(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))))
#-gcl (declare (dynamic-extent #'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)))))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
;;;; Jesse Hager: The Windows Shortcut File Format.
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun* read-null-terminated-string (s)
(with-output-to-string (out)
(loop :for code = (read-byte s)
:until (zerop code)
:do (write-char (code-char code) out))))
(defun* read-little-endian (s &optional (bytes 4))
(loop :for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun* parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(fli-flags (read-little-endian s))
(local-volume-offset (read-little-endian s))
(local-offset (read-little-endian s))
(network-volume-offset (read-little-endian s))
(remaining-offset (read-little-endian s)))
(declare (ignore total-length end-of-header local-volume-offset))
(unless (zerop fli-flags)
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
(strcat (read-null-terminated-string s)
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
(defun* parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(when (and (= (read-little-endian s) *link-initial-dword*)
(let ((header (make-array (length *link-guid*))))
(read-sequence header s)
(equalp header *link-guid*)))
(let ((flags (read-little-endian s)))
(file-position s 76) ;skip rest of header
(when (logbitp 0 flags)
;; skip shell item id list
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
((logbitp 1 flags)
(parse-file-location-info s))
(when (logbitp 2 flags)
;; skip description string
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(when (logbitp 3 flags)
;; finally, our pathname
(let* ((length (read-little-endian s 2))
(buffer (make-array length)))
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
(end-of-file (c)
(declare (ignore c))
This diff is collapsed.
......@@ -160,11 +160,11 @@ system names to pathnames of .asd files")
#+scl (:tree #p"file://modules/")))
(defun* default-source-registry ()