Commit f98aaa6b authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Introduce an *asdf-session* that may contain more than a cache.

Replace with-asdf-cache with with-asdf-session.
Introduce *asdf-session-class* to hold the class of the session.
Introduce caching-cache, currently the only session class,
that only contains a cache, for now.
parent 49dbfc0c
......@@ -6249,24 +6249,17 @@ Here's the procedure for experimenting with tests in a REPL:
;; Load the test script support.
(load "script-support.lisp")
;; Initialize the script support.
;; This will also change your *package* to asdf-test.
;; Initialize the script support for interaction.
;; This will also change your *package* to asdf-test
;; after frobbing the asdf-test package to make it usable.
;; NB: this function is also available from package cl-user,
;; and also available with the shorter name da in both packages.
(asdf-test::debug-asdf)
;; In case you modified ASDF since you last tested it,
;; you need to update asdf.lisp itself by evaluating 'make' in a shell,
;; or (require "asdf") (asdf:load-system :asdf) in another CL REPL,
;; if not done in this REPL above.
;; *Then*, in this REPL, you need to evaluate:
;(asdf-test::compile-load-asdf)
(asdf-test:debug-asdf)
;; Now, you may experiment with test code from a .script file.
;; See the instructions given at the end of your failing test
;; to identify which form is needed, e.g.
(frob-packages)
(asdf::with-asdf-cache () (load "test-utilities.script"))
(run-test-script "test-utilities.script")
@end example
......
......@@ -393,7 +393,7 @@ Going forward, we recommend new users should be using the source-registry.")
;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
;; NB: this function depends on a corresponding side-effect in parse-defsystem;
;; the precise protocol between the two functions may change in the future (or not).
(first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
(defun load-asd (pathname
&key name (external-format (encoding-external-format (detect-encoding pathname)))
......@@ -402,7 +402,7 @@ Going forward, we recommend new users should be using the source-registry.")
NAME if supplied is the name of a system expected to be defined in that file.
Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(with-asdf-cache ()
(with-asdf-session ()
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
......@@ -479,7 +479,7 @@ PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
(with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
(with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
;; and keeping a negative cache was a bug (see lp#1335323), which required
;; explicit invalidation in clear-system and find-system (when unsucccessful).
(let* ((name (coerce-name name))
......@@ -507,7 +507,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results.
(defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name))
(with-asdf-session (:key `(find-system ,name))
(let ((primary-name (primary-system-name name)))
(unless (equal name primary-name)
(find-system primary-name nil)))
......
......@@ -57,7 +57,7 @@ But do NOT depend on it, for this is deprecated behavior."))
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(nest
(with-asdf-cache ())
(with-asdf-session ())
(let ((in-operate *in-operate*)
(*in-operate* t)
(operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
......@@ -249,11 +249,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(defun restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
(let ((systems-being-defined
(when *asdf-cache*
(when *asdf-session*
(prog1
(loop :for k :being :the hash-keys :of *asdf-cache*
(loop :for k :being :the hash-keys :of (asdf-cache)
:when (eq (first k) 'find-system) :collect (second k))
(clrhash *asdf-cache*)))))
(clrhash (asdf-cache))))))
;; Regardless, clear defined systems, since they might be invalid
;; after an incompatible ASDF upgrade.
(clear-defined-systems)
......
......@@ -288,7 +288,7 @@ system names contained using COERCE-NAME. Return the result."
;; that is registered to a different location to find-system,
;; we also need to remember it in the asdf-cache.
(nest
(with-asdf-cache ())
(with-asdf-session ())
(let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
(flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))
......
......@@ -5,9 +5,10 @@
(:recycle :asdf/session :asdf/cache)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
#:call-with-asdf-session #:with-asdf-session
#:*asdf-session* #:*asdf-session-class* #:caching-session
#:clear-configuration-and-retry #:retry))
(in-package :asdf/session)
......@@ -20,29 +21,35 @@
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
(with-upgradability ()
;; The session cache variable.
;; NIL when outside a session, an equal hash-table when inside a session.
(defvar *asdf-cache* nil)
;; The session variable.
;; NIL when outside a session.
(defvar *asdf-session* nil)
(defparameter* *asdf-session-class* 'caching-session)
(defclass caching-session ()
((cache :initform (make-hash-table :test 'equal) :reader session-cache)))
(defun asdf-cache ()
(session-cache *asdf-session*))
;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
;; Return those values.
(defun set-asdf-cache-entry (key value-list)
(values-list (if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
(values-list (if *asdf-session*
(setf (gethash key (asdf-cache)) value-list)
value-list)))
;; Unset the session cache entry for KEY, when inside a session.
(defun unset-asdf-cache-entry (key)
(when *asdf-cache*
(remhash key *asdf-cache*)))
(when *asdf-session*
(remhash key (session-cache *asdf-session*))))
;; Consult the session cache entry for KEY if present and in a session;
;; if not present, compute it by calling the THUNK,
;; and set the session cache entry accordingly, if in a session.
;; Return the values from the cache and/or the thunk computation.
(defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if *asdf-session*
(multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
(if foundp
(values-list results)
(set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
......@@ -58,13 +65,13 @@
;; Second, if a new session was started, establish restarts for retrying the overall computation.
;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
;; entry isn't found, or just call the THUNK if no KEY was specified.
(defun call-with-asdf-cache (thunk &key override key)
(defun call-with-asdf-session (thunk &key override key)
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override))
(if (and *asdf-session* (not override))
(funcall fun)
(loop
(restart-case
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(let ((*asdf-session* (make-instance *asdf-session-class*)))
(return (funcall fun)))
(retry ()
:report (lambda (s)
......@@ -74,9 +81,9 @@
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clear-configuration)))))))
;; Syntactic sugar for call-with-asdf-cache
(defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
;; Syntactic sugar for call-with-asdf-session
(defmacro with-asdf-session ((&key key override) &body body)
`(call-with-asdf-session #'(lambda () ,@body) :override ,override :key ,key))
;;; Define specific accessor for file (date) stamp.
......
......@@ -169,7 +169,7 @@
(logical-pathname-p module-pathname))
(and (stringp file-pathname) (find #\. file-pathname)))
(incf system-count)
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(clear-system :test-system)
(let* ((system (let ((*verbose-out* nil))
(eval system-definition)))
......
......@@ -156,7 +156,7 @@ do_tests () {
echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2
echo "(cd test ; $icmd )" >&2
echo "then copy/paste:" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-cache () (load \"$i\")))" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-session () (load \"$i\")))" >&2
fi
echo >&2
echo >&2
......
......@@ -337,12 +337,12 @@ Some constraints:
(assert-equal (file-write-date file) stamp))
;; else
(progn
(unless (asymval :*asdf-cache*)
(error "Trying to use *ASDF-CACHE* in TOUCH-FILE, but cache is not initialized."))
(unless (asymval :*asdf-session*)
(error "Trying to use the ASDF session cache in TOUCH-FILE, but it is not initialized."))
(acall :register-file-stamp file stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
(unless (asymval :*asdf-session*) (error "Y U NO use asdf session?"))
(acall :register-file-stamp (acall :normalize-namestring file) nil))
(defun hash-table->alist (table)
......@@ -408,7 +408,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-asdf-cache) 'funcall) thunk)
(funcall (or (asym :call-with-asdf-session) 'funcall) thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
......@@ -632,10 +632,10 @@ is bound, write a message and exit on an error. If
(when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(funcall
;; Old versions of ASDF don't always use with-asdf-cache in locate system, but need it.
;; Old versions of ASDF don't always use with-asdf-session in locate system, but need it.
;; So we do it for them for the sake of testing upgrade from these old versions.
;; Yet older versions of ASDF don't even have this cache, so then we don't.
(or (asym :call-with-asdf-cache) 'funcall)
;; Yet older versions of ASDF don't even have this session cache, so then we don't.
(or (asym :call-with-asdf-session) (asym :call-with-asdf-cache) 'funcall)
(lambda ()
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%")
......@@ -680,7 +680,7 @@ is bound, write a message and exit on an error. If
(defun debug-asdf ()
(setf *debug-asdf* t)
(setf *quit-when-done* nil)
(setf *package* (find-package :asdf-test)))
(frob-packages))
(defun just-load-asdf-fasl () (load-asdf-fasl))
......@@ -748,7 +748,7 @@ is bound, write a message and exit on an error. If
(defun clear-cache ()
;; Or, should we preserve the timestamps?
(clrhash (asymval :*asdf-cache*)))
(clrhash (acall :asdf-cache)))
;; These are shorthands for interactive debugging of test scripts:
(!a
......
......@@ -37,6 +37,7 @@
#+asdf :asdf))
(defvar *default-defsystem* (first *defsystems*))
(defvar asdf::*asdf-cache* nil) ;; if defparameter instead of defvar, disable any surrounding cache
(defvar asdf::*asdf-session* nil) ;; if defparameter instead of defvar, disable any surrounding cache
(defun lisppath (filename) (asdf::subpathname *tsp* filename))
(defun faslpath (lisppath &optional (defsystem *default-defsystem*))
......@@ -51,8 +52,11 @@
(defun use-cache-p (defsystem)
(and (eq defsystem :asdf)
(asdf:version-satisfies (asdf:asdf-version) "2.27")
asdf::*asdf-cache*))
(cond
((asdf:version-satisfies (asdf:asdf-version) "3.1.7.30")
asdf::*asdf-session*)
((asdf:version-satisfies (asdf:asdf-version) "2.27")
asdf::*asdf-cache*))))
#+allegro
(excl:defsystem :test-stamp-propagation
......@@ -92,7 +96,6 @@
"file2.lisp"))
(defun reload (&optional (defsystem *default-defsystem*))
(format t "~&ASDF-CACHE before ~S~%" asdf::*asdf-cache*)
(setf *eval-notes* nil)
(setf *compile-verbose* t *load-verbose* t)
(ecase defsystem
......@@ -118,7 +121,6 @@
#+allegro (excl:load-system :test-stamp-propagation)
#+lispworks (scm:load-system :test-stamp-propagation)
#+genera (sct:load-system :test-stamp-propagation)))
(format t "~&ASDF-CACHE after ~S~%" asdf::*asdf-cache*)
(let ((n (eval-notes)))
(format t "~&EVAL-NOTES ~S~%" n)
n))
......@@ -143,7 +145,7 @@
(defun clear-fasls (&optional (defsystem *default-defsystem*))
(loop :for file :in '("file1.lisp" "file2.lisp")
:for faslpath = (faslpath file defsystem)
:do (if (and (eq defsystem :asdf) asdf::*asdf-cache*)
:do (if (use-cache-p defsystem)
(mark-file-deleted faslpath)
(delete-file-if-exists faslpath))))
......@@ -153,7 +155,7 @@
:test 'equal :from-end t))
(defun adjust-stamp-cache (base l1 f1 l2 f2)
(clrhash asdf::*asdf-cache*)
(clrhash (asdf::asdf-cache))
(touch-file (lisppath "file1.lisp") :timestamp base :offset l1)
(touch-file (faslpath "file1.lisp") :timestamp base :offset f1)
(dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file1")))
......
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(load-system "test-asdf/test-module-depend"))
(defparameter *plan* (make-plan () 'load-op "test-asdf/test-module-depend"))
......
......@@ -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-asdf-cache (:override t)
`(with-asdf-session (:override t)
(format t "~&Test ~A: should be ~A~%" ',sys ',encoding)
(setf *lambda-string* nil)
,def-test-system
......
......@@ -10,7 +10,7 @@
`(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf")
:wilden t))))
(setf asdf/session:*asdf-cache* nil)
(setf asdf/session:*asdf-session* nil)
(DBG :logical
(logical-pathname-translations "ASDF")
......
......@@ -3,7 +3,7 @@
(defun current-system-source-file (x)
(system-source-file (asdf::registered-system x)))
(with-asdf-cache ()
(with-asdf-session (:override t)
(DBG "loading test-mutual-redefinition-1")
(let ((warned-p nil))
(handler-bind ((bad-system-name (lambda (c)
......@@ -28,7 +28,7 @@
(test-source "test-mutual-redefinition-1.asd")
(current-system-source-file "test-mutual-redefinition-2"))
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(DBG "loading test-mutual-redefinition-2 in a different cache session")
(load-system 'test-mutual-redefinition-2)
(assert-pathname-equal
......
......@@ -6,7 +6,7 @@
(defvar *caught-error* nil)
(delete-file-if-exists (test-source "try-reloading-dependency.asd"))
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(handler-bind
((error #'(lambda (c)
(format t "~&Caught error ~s" c)
......
......@@ -21,7 +21,7 @@
(DBG "Correctly failed to find system.")
(defvar *attempts* 0)
(assert
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(handler-bind
((asdf:missing-component
#'(lambda (c)
......@@ -45,12 +45,8 @@
(def-test-system test-missing-dependency
:depends-on ("test-asdf/force1")
:components ((:file "file2")))
;; (trace find-system)
;; (trace find-component)
;; (trace asdf::component-find-path)
;; (trace operate)
(setf *attempts* 0)
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(flet ((handle-missing (c)
(if (zerop *attempts*)
(let ((missing (asdf::missing-requires c)))
......
;;; -*- Lisp -*-
(setf asdf/session:*asdf-cache* nil) ;; disable cache between those two very different compilations.
;; Disable cache between those two very different compilations.
(setf asdf/session:*asdf-session* nil)
#-(and ecl ecl-bytecmp)
(setf asdf::*load-system-operation* 'load-bundle-op) ;; This triggers a bug on ECL no more!
......
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