cache.lisp 5.1 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
;;;; Session cache
3

4
(uiop/package:define-package :asdf/cache
5
  (:use :uiop/common-lisp :uiop :asdf/upgrade)
6
  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
7
           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
8
           #:do-asdf-cache #:normalize-namestring
9
           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
10
           #:clear-configuration-and-retry #:retry))
11 12
(in-package :asdf/cache)

13
;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
14
;; * Consistency in the view of the world relied on by ASDF within a given session.
15
;;   Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
16
;;   (a.k.a. stack overflows) and other erratic behavior.
17 18
;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
;;   no expensive recomputations of transitive dependencies for some input-files or output-files.
19
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
20

21
(with-upgradability ()
22 23
  ;; The session cache variable.
  ;; NIL when outside a session, an equal hash-table when inside a session.
24 25
  (defvar *asdf-cache* nil)

26 27
  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
  ;; Return those values.
28
  (defun set-asdf-cache-entry (key value-list)
29 30 31
    (values-list (if *asdf-cache*
                     (setf (gethash key *asdf-cache*) value-list)
                     value-list)))
32

33
  ;; Unset the session cache entry for KEY, when inside a session.
34 35 36 37
  (defun unset-asdf-cache-entry (key)
    (when *asdf-cache*
      (remhash key *asdf-cache*)))

38 39 40 41
  ;; 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.
42
  (defun consult-asdf-cache (key &optional thunk)
43 44 45
    (if *asdf-cache*
        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
          (if foundp
46
              (values-list results)
47 48
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
49

50
  ;; Syntactic sugar for consult-asdf-cache
51 52 53
  (defmacro do-asdf-cache (key &body body)
    `(consult-asdf-cache ,key #'(lambda () ,@body)))

54 55 56 57 58 59
  ;; Compute inside a ASDF session with a cache.
  ;; First, make sure an ASDF session is underway, by binding the session cache variable
  ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
  ;; 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.
60 61 62 63
  (defun call-with-asdf-cache (thunk &key override key)
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
      (if (and *asdf-cache* (not override))
          (funcall fun)
64
          (loop
65
            (restart-case
66 67 68 69 70 71
                (let ((*asdf-cache* (make-hash-table :test 'equal)))
                  (return (funcall fun)))
              (retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
              (clear-configuration-and-retry ()
72
                :report (lambda (s)
73 74
                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
                (clear-configuration)))))))
75

76
  ;; Syntactic sugar for call-with-asdf-cache
77 78
  (defmacro with-asdf-cache ((&key key override) &body body)
    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
79

80 81 82 83

  ;;; Define specific accessor for file (date) stamp.

  ;; Normalize a namestring for use as a key in the session cache.
84 85 86
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
87
                      (physicalize-pathname pathname)
88 89
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
90

91
  ;; Compute the file stamp for a normalized namestring
92 93 94
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
      (safe-file-write-date normalized-namestring)))
95

96 97
  ;; Override the time STAMP associated to a given FILE in the session cache.
  ;; If no STAMP is specified, recompute a new one from the filesystem.
98 99 100 101
  (defun register-file-stamp (file &optional (stamp nil stampp))
    (let* ((namestring (normalize-namestring file))
           (stamp (if stampp stamp (compute-file-stamp namestring))))
      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
102

103
  ;; Get or compute a memoized stamp for given FILE from the session cache.
104
  (defun get-file-stamp (file)
105 106 107
    (when file
      (let ((namestring (normalize-namestring file)))
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
108