Skip to content
Snippets Groups Projects
Commit 1f4d6fec authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.153: Various speed ups.

Between 2.26 and 2.26.152, ASDF had gotten ~37 times slower at traversing iolib.
Now trying to restore some performance.

This commit:
1- generalizes the cache to cover input-files and output-files as well as get-file-stamp.
2- removes the probe-file before file-write-date.
parent 9cbd3a23
No related branches found
No related tags found
No related merge requests found
......@@ -43,7 +43,7 @@ XCL ?= xcl
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
defsystem_lisp := upgrade.lisp component.lisp system.lisp stamp-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
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:
build/asdf.lisp: $(wildcard *.lisp)
......
......@@ -5,7 +5,7 @@
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
:asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
(:intern #:stamp #:done-p)
(:export
#:action #:define-convenience-action-methods
......@@ -17,8 +17,7 @@
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:feature
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
#:action-path #:find-action
))
#:action-path #:find-action))
(in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
......@@ -164,22 +163,23 @@ You can put together sentences using this phrase."))
t)
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
"Translate output files, unless asked not to. Memoize the result."
operation component ;; hush genera, not convinced by declare ignorable(!)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-pathname-absolute pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t))
(do-asdf-cache `(output-files ,operation ,component)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-pathname-absolute pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t)))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
nil)
......@@ -189,6 +189,11 @@ You can put together sentences using this phrase."))
(assert (length=n-p files 1))
(first files)))
(defmethod input-files :around (operation component)
"memoize input files."
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
(defmethod input-files ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
......
......@@ -34,18 +34,18 @@
((:file "upgrade")
(:file "component" :depends-on ("upgrade"))
(:file "system" :depends-on ("component"))
(:file "stamp-cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "stamp-cache"))
(:file "cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("upgrade"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "action" :depends-on ("find-component" "operation" "cache"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action" "stamp-cache"))
(:file "plan" :depends-on ("lisp-action" "cache"))
(:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "backward-internals" :depends-on ("lisp-action" "operate"))
(:file "defsystem" :depends-on ("backward-internals" "stamp-cache"))
(:file "defsystem" :depends-on ("backward-internals" "cache"))
(:file "bundle" :depends-on ("lisp-action"))
(:file "concatenate-source" :depends-on ("bundle"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
......@@ -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.152" ;; to be automatically updated by make bump-version
:version "2.26.153" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
:components
......
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
(asdf/package:define-package :asdf/stamp-cache
(asdf/package:define-package :asdf/cache
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:call-with-stamp-cache #:with-stamp-cache #:*stamp-cache*))
(in-package :asdf/stamp-cache)
#:consult-asdf-cache #:do-asdf-cache
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache)
;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(defvar *stamp-cache* nil)
(defvar *asdf-cache* nil)
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(if *stamp-cache*
(setf (gethash file *stamp-cache*) stamp)
stamp))
(defun set-asdf-cache-entry (key value-list)
(apply 'values
(if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun get-file-stamp (file)
(if *stamp-cache*
(multiple-value-bind (stamp foundp) (gethash file *stamp-cache*)
(defun consult-asdf-cache (key thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
stamp
(register-file-stamp file)))
(compute-file-stamp file)))
(apply 'values results)
(set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
(funcall thunk)))
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
(defun call-with-stamp-cache (thunk &key override)
(if (and *stamp-cache* (not override))
(defun call-with-asdf-cache (thunk &key override)
(if (and *asdf-cache* (not override))
(funcall thunk)
(let ((*stamp-cache* (make-hash-table :test 'equal)))
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(funcall thunk))))
(defmacro with-stamp-cache ((&key override) &body body)
`(call-with-stamp-cache #'(lambda () ,@body) :override ,override))
(defmacro with-asdf-cache ((&key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
(defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/defsystem
(:recycle :asdf/defsystem :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/stamp-cache
:asdf/component :asdf/system :asdf/cache
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
:asdf/backward-internals)
(:export
......
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/stamp-cache)
:asdf/component :asdf/system :asdf/cache)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name
......@@ -240,9 +240,9 @@ Going forward, we recommend new users should be using the source-registry.
(defun* call-with-system-definitions (thunk)
(if *systems-being-defined*
(call-with-stamp-cache thunk)
(call-with-asdf-cache thunk)
(let ((*systems-being-defined* (make-hash-table :test 'equal)))
(call-with-stamp-cache thunk))))
(call-with-asdf-cache thunk))))
(defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body)))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.152: Another System Definition Facility.
;;; This is ASDF 2.26.153: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -10,7 +10,7 @@
#:split #:make-collector
#:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/stamp-cache
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
......
......@@ -18,6 +18,7 @@
#:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
#:environment-output-translations #:process-output-translations
#:compute-output-translations
#+abcl #:translate-jar-pathname
))
(in-package :asdf/output-translations)
......
......@@ -401,7 +401,7 @@ or the original (parsed) pathname if it is false (the default)."
;; and we can survive and we will continue the planning
;; as if the file were very old.
;; (or should we treat the case in a different, special way?)
(and (probe-file* pathname) (ignore-errors (file-write-date pathname))))
(handler-case (file-write-date pathname) (file-error () nil)))
(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
(apply 'directory pathname-spec
......
......@@ -5,7 +5,7 @@
(:recycle :asdf/plan :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/operation :asdf/system
:asdf/stamp-cache :asdf/find-system :asdf/find-component
:asdf/cache :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action)
(:export
#:component-operation-time #:mark-operation-done
......
......@@ -216,7 +216,7 @@ Some constraints:
(defun touch-file (file &key offset timestamp)
(let* ((base (or timestamp (get-universal-time)))
(stamp (if offset (+ base offset) base)))
(if (asymval :*stamp-cache*)
(if (asymval :*asdf-cache*)
(acall :register-file-stamp file stamp)
(multiple-value-bind (sec min hr day month year)
(decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
......@@ -227,7 +227,7 @@ Some constraints:
,(acall :native-namestring file)))
(assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*stamp-cache*) (error "Y U NO use stamp cache?"))
(unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
(acall :register-file-stamp file nil))
(defun hash-table->alist (table)
......@@ -290,7 +290,7 @@ is bound, write a message and exit on an error. If
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1))))))
(funcall (or (asym :call-with-stamp-cache :asdf nil) 'funcall) thunk)
(funcall (or (asym :call-with-asdf-cache :asdf nil) 'funcall) thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
......@@ -496,7 +496,7 @@ is bound, write a message and exit on an error. If
(load-asdf-fasl tag)
(use-package :asdf :asdf-test)
(use-package :asdf/driver :asdf-test)
(use-package :asdf/stamp-cache :asdf-test)
(use-package :asdf/cache :asdf-test)
(configure-asdf)
(setf *package* (find-package :asdf-test)))
......
......@@ -21,7 +21,7 @@
(defmacro with-encoding-test ((encoding &key (op 'load-source-op) (path "lambda")) def-test-system &body body)
(let ((sys (second def-test-system)))
`(with-stamp-cache (:override t)
`(with-asdf-cache (:override t)
(format t "~&Test ~A: should be ~A~%" ',sys ',encoding)
(setf *lambda-string* nil)
,def-test-system
......
......@@ -19,7 +19,6 @@
(assert date1)
(touch-file test1.asd :timestamp date1 :offset +2)
(find-system :test1)
;;(DBG :bloh (hash-table->alist asdf::*stamp-cache*))
(defparameter date2 (system-registered-time :test1))
(assert date2)
(assert (> date2 date1))
......@@ -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.152")
(asdf-version "2.26.153")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))
......
"2.26.152"
"2.26.153"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment