session.lisp 9.73 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
   #:visited-actions #:visiting-action-set #:visiting-action-list
   #:total-action-count #:planned-action-count #:planned-output-action-count
   #:clear-configuration-and-retry #:retry
18
   #:operate-level
19 20 21
   ;; 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))
22
(in-package :asdf/session)
23 24


25
(with-upgradability ()
26 27 28
  ;; The session variable.
  ;; NIL when outside a session.
  (defvar *asdf-session* nil)
29 30 31 32 33 34 35 36 37 38 39 40
  (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.
41 42 43
     (ancestor
      :initform nil :initarg :ancestor :reader session-ancestor
      :documentation "Top level session that this is part of")
44
     (session-cache
45
      :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
46
      :documentation "Memoize expensive computations")
47 48 49 50 51
     (operate-level
      :initform 0 :initarg :operate-level :accessor session-operate-level
      :documentation "Number of nested calls to operate we're under (for toplevel session only)")
     ;; shouldn't the below be superseded by the session-wide caching of action-status
     ;; for (load-op "asdf") ?
52 53 54
     (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.")
55 56 57
     (forcing
      :initform nil :initarg :forcing :accessor forcing
      :documentation "Forcing parameters for the session")
58 59 60 61 62 63 64 65 66 67 68 69 70
     ;; 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"))
71

72 73 74
  (defun toplevel-asdf-session ()
    (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))

75 76 77 78 79 80
  (defun operate-level ()
    (session-operate-level (toplevel-asdf-session)))

  (defun (setf operate-level) (new-level)
    (setf (session-operate-level (toplevel-asdf-session)) new-level))

81 82
  (defun asdf-cache ()
    (session-cache *asdf-session*))
83

84 85
  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
  ;; Return those values.
86
  (defun set-asdf-cache-entry (key value-list)
87 88
    (values-list (if *asdf-session*
                     (setf (gethash key (asdf-cache)) value-list)
89
                     value-list)))
90

91
  ;; Unset the session cache entry for KEY, when inside a session.
92
  (defun unset-asdf-cache-entry (key)
93 94
    (when *asdf-session*
      (remhash key (session-cache *asdf-session*))))
95

96 97 98 99
  ;; 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.
100
  (defun consult-asdf-cache (key &optional thunk)
101 102
    (if *asdf-session*
        (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
103
          (if foundp
104
              (values-list results)
105 106
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
107

108
  ;; Syntactic sugar for consult-asdf-cache
109 110 111
  (defmacro do-asdf-cache (key &body body)
    `(consult-asdf-cache ,key #'(lambda () ,@body)))

112 113 114 115 116 117
  ;; 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.
118
  (defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
119
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
120
      (if (and (not override) *asdf-session*)
121
          (funcall fun)
122
          (loop
123
            (restart-case
124 125 126 127
                (let ((*asdf-session*
                       (apply 'make-instance *asdf-session-class*
                              (when *asdf-session*
                                `(:ancestor ,(toplevel-asdf-session)
128 129
                                  ,@(unless override-forcing
                                      `(:forcing ,(forcing *asdf-session*)))
130 131
                                  ,@(unless override-cache
                                      `(:session-cache ,(session-cache *asdf-session*))))))))
132 133 134 135 136
                  (return (funcall fun)))
              (retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
              (clear-configuration-and-retry ()
137
                :report (lambda (s)
138
                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
139
                (clrhash (session-cache *asdf-session*))
140
                (clear-configuration)))))))
141

142
  ;; Syntactic sugar for call-with-asdf-session
143
  (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
144
    `(call-with-asdf-session
145 146 147
      #'(lambda () ,@body)
      :override ,override :key ,key
      :override-cache ,override-cache :override-forcing ,override-forcing))
148

149 150 151 152

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

  ;; Normalize a namestring for use as a key in the session cache.
153 154 155
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
156
                      (physicalize-pathname pathname)
157 158
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
159

160
  ;; Compute the file stamp for a normalized namestring
161 162
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
163
      (or (safe-file-write-date normalized-namestring) t)))
164

165 166
  ;; 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.
167 168 169 170
  (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))))
171

172
  ;; Get or compute a memoized stamp for given FILE from the session cache.
173
  (defun get-file-stamp (file)
174 175
    (when file
      (let ((namestring (normalize-namestring file)))
176
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
177

178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198

  ;;; 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)))