session.lisp 8.03 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
;;;; Session cache
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 13 14 15 16 17 18 19
  (: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
   #:*asdf-session* #:*asdf-session-class* #:session #:session-plan
   #: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))
20
(in-package :asdf/session)
21 22


23
(with-upgradability ()
24 25 26
  ;; The session variable.
  ;; NIL when outside a session.
  (defvar *asdf-session* nil)
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
  (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.
     (cache
      :initform (make-hash-table :test 'equal) :reader session-cache
      :documentation "Memoize expensive computations")
     (plan
      :initform nil :accessor session-plan
      :documentation "Dependency graph of actions")
     ;; 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"))
58 59 60

  (defun asdf-cache ()
    (session-cache *asdf-session*))
61

62 63
  ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
  ;; Return those values.
64
  (defun set-asdf-cache-entry (key value-list)
65 66
    (values-list (if *asdf-session*
                     (setf (gethash key (asdf-cache)) value-list)
67
                     value-list)))
68

69
  ;; Unset the session cache entry for KEY, when inside a session.
70
  (defun unset-asdf-cache-entry (key)
71 72
    (when *asdf-session*
      (remhash key (session-cache *asdf-session*))))
73

74 75 76 77
  ;; 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.
78
  (defun consult-asdf-cache (key &optional thunk)
79 80
    (if *asdf-session*
        (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
81
          (if foundp
82
              (values-list results)
83 84
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
85

86
  ;; Syntactic sugar for consult-asdf-cache
87 88 89
  (defmacro do-asdf-cache (key &body body)
    `(consult-asdf-cache ,key #'(lambda () ,@body)))

90 91 92 93 94 95
  ;; 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.
96
  (defun call-with-asdf-session (thunk &key override key)
97
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
98
      (if (and *asdf-session* (not override))
99
          (funcall fun)
100
          (loop
101
            (restart-case
102
                (let ((*asdf-session* (make-instance *asdf-session-class*)))
103 104 105 106 107
                  (return (funcall fun)))
              (retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
              (clear-configuration-and-retry ()
108
                :report (lambda (s)
109 110
                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
                (clear-configuration)))))))
111

112 113 114
  ;; 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))
115

116 117 118 119

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

  ;; Normalize a namestring for use as a key in the session cache.
120 121 122
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
123
                      (physicalize-pathname pathname)
124 125
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
126

127
  ;; Compute the file stamp for a normalized namestring
128 129 130
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
      (safe-file-write-date normalized-namestring)))
131

132 133
  ;; 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.
134 135 136 137
  (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))))
138

139
  ;; Get or compute a memoized stamp for given FILE from the session cache.
140
  (defun get-file-stamp (file)
141 142
    (when file
      (let ((namestring (normalize-namestring file)))
143
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
144

145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165

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