session.lisp 9.21 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
;;;; Session
3

4
(uiop/package:define-package :asdf/session
5 6
  (:recycle :asdf/session :asdf/cache :asdf/component
            :asdf/action :asdf/find-system :asdf/plan :asdf)
7
  (:use :uiop/common-lisp :uiop :asdf/upgrade)
8 9 10 11 12
  (:export
   #:get-file-stamp #:compute-file-stamp #:register-file-stamp
   #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
   #:do-asdf-cache #:normalize-namestring
   #:call-with-asdf-session #:with-asdf-session
13
   #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
14
   #:session-cache #:forcing #:asdf-upgraded-p
15 16 17 18 19 20
   #:visited-actions #:visiting-action-set #:visiting-action-list
   #:total-action-count #:planned-action-count #:planned-output-action-count
   #:clear-configuration-and-retry #:retry
   ;; conditions
   #:system-definition-error ;; top level, moved here because this is the earliest place for it.
   #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
21
(in-package :asdf/session)
22 23


24
(with-upgradability ()
25 26 27
  ;; The session variable.
  ;; NIL when outside a session.
  (defvar *asdf-session* nil)
28 29 30 31 32 33 34 35 36 37 38 39
  (defparameter* *asdf-session-class* 'session
    "The default class for sessions")

  (defclass session ()
    (;; The ASDF session cache is used to memoize some computations.
     ;; It is instrumental in achieving:
     ;; * Consistency in the view of the world relied on by ASDF within a given session.
     ;;   Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
     ;;   (a.k.a. stack overflows) and other erratic behavior.
     ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
     ;;   no expensive recomputations of transitive dependencies for input-files or output-files.
     ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
40 41 42
     (ancestor
      :initform nil :initarg :ancestor :reader session-ancestor
      :documentation "Top level session that this is part of")
43
     (session-cache
44
      :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
45
      :documentation "Memoize expensive computations")
46 47 48
     (asdf-upgraded-p
      :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
      :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
49 50 51
     (forcing
      :initform nil :initarg :forcing :accessor forcing
      :documentation "Forcing parameters for the session")
52 53 54 55 56 57 58 59 60 61 62 63 64
     ;; Table that to actions already visited while walking the dependencies associates status
     (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
     ;; Actions that depend on those being currently walked through, to detect circularities
     (visiting-action-set ;; as a set
      :initform (make-hash-table :test 'equal) :accessor visiting-action-set)
     (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list
     ;; Counts of total actions in plan
     (total-action-count :initform 0 :accessor total-action-count)
     ;; Count of actions that need to be performed
     (planned-action-count :initform 0 :accessor planned-action-count)
     ;; Count of actions that need to be performed that have a non-empty list of output-files.
     (planned-output-action-count :initform 0 :accessor planned-output-action-count))
    (:documentation "An ASDF session with a cache to memoize some computations"))
65

66 67 68
  (defun toplevel-asdf-session ()
    (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))

69 70
  (defun asdf-cache ()
    (session-cache *asdf-session*))
71

72 73
  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
  ;; Return those values.
74
  (defun set-asdf-cache-entry (key value-list)
75 76
    (values-list (if *asdf-session*
                     (setf (gethash key (asdf-cache)) value-list)
77
                     value-list)))
78

79
  ;; Unset the session cache entry for KEY, when inside a session.
80
  (defun unset-asdf-cache-entry (key)
81 82
    (when *asdf-session*
      (remhash key (session-cache *asdf-session*))))
83

84 85 86 87
  ;; 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.
88
  (defun consult-asdf-cache (key &optional thunk)
89 90
    (if *asdf-session*
        (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
91
          (if foundp
92
              (values-list results)
93 94
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
95

96
  ;; Syntactic sugar for consult-asdf-cache
97 98 99
  (defmacro do-asdf-cache (key &body body)
    `(consult-asdf-cache ,key #'(lambda () ,@body)))

100 101 102 103 104 105
  ;; 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.
106
  (defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
107
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
108
      (if (and (not override) *asdf-session*)
109
          (funcall fun)
110
          (loop
111
            (restart-case
112 113 114 115
                (let ((*asdf-session*
                       (apply 'make-instance *asdf-session-class*
                              (when *asdf-session*
                                `(:ancestor ,(toplevel-asdf-session)
116 117
                                  ,@(unless override-forcing
                                      `(:forcing ,(forcing *asdf-session*)))
118 119
                                  ,@(unless override-cache
                                      `(:session-cache ,(session-cache *asdf-session*))))))))
120 121 122 123 124
                  (return (funcall fun)))
              (retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
              (clear-configuration-and-retry ()
125
                :report (lambda (s)
126
                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
127
                (clrhash (session-cache *asdf-session*))
128
                (clear-configuration)))))))
129

130
  ;; Syntactic sugar for call-with-asdf-session
131
  (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
132
    `(call-with-asdf-session
133 134 135
      #'(lambda () ,@body)
      :override ,override :key ,key
      :override-cache ,override-cache :override-forcing ,override-forcing))
136

137 138 139 140

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

  ;; Normalize a namestring for use as a key in the session cache.
141 142 143
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
144
                      (physicalize-pathname pathname)
145 146
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
147

148
  ;; Compute the file stamp for a normalized namestring
149 150 151
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
      (safe-file-write-date normalized-namestring)))
152

153 154
  ;; 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.
155 156 157 158
  (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))))
159

160
  ;; Get or compute a memoized stamp for given FILE from the session cache.
161
  (defun get-file-stamp (file)
162 163
    (when file
      (let ((namestring (normalize-namestring file)))
164
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
165

166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186

  ;;; Conditions

  (define-condition system-definition-error (error) ()
    ;; [this use of :report should be redundant, but unfortunately it's not.
    ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    ;; over print-object; this is always conditions::%print-condition for
    ;; condition objects, which in turn does inheritance of :report options at
    ;; run-time.  fortunately, inheritance means we only need this kludge here in
    ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    #+cmucl (:report print-object))

  (define-condition formatted-system-definition-error (system-definition-error)
    ((format-control :initarg :format-control :reader format-control)
     (format-arguments :initarg :format-arguments :reader format-arguments))
    (:report (lambda (c s)
               (apply 'format s (format-control c) (format-arguments c)))))

  (defun sysdef-error (format &rest arguments)
    (error 'formatted-system-definition-error :format-control
           format :format-arguments arguments)))