action.lisp 23.2 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Actions

4
(uiop/package:define-package :asdf/action
5
  (:nicknames :asdf-action)
6
  (:recycle :asdf/action :asdf)
7
  (:use :uiop/common-lisp :uiop :asdf/upgrade
8
   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
9
  (:export
10
   #:action #:define-convenience-action-methods
11
   #:explain #:action-description
12
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
13
   #:component-depends-on
14 15 16
   #:input-files #:output-files #:output-file #:operation-done-p
   #:action-status #:action-stamp #:action-done-p
   #:component-operation-time #:mark-operation-done #:compute-action-stamp
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
17
   #:perform #:perform-with-restarts #:retry #:accept
18
   #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
19
   #:action-path #:find-action #:stamp #:done-p
20
   #:operation-definition-warning #:operation-definition-error ;; condition
21
   ))
22 23
(in-package :asdf/action)

24
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
25 26 27 28 29

  (deftype action ()
    "A pair of operation and component uniquely identifies a node in the dependency graph
of steps to be performed while building a system."
    '(cons operation component))
30 31

  (deftype operation-designator ()
32 33
    "An operation designates itself. NIL designates a context-dependent current operation,
and a class-name or class designates the canonical instance of the designated class."
34
    '(or operation null symbol class)))
35

36 37

;;; TODO: These should be moved to asdf/plan and be made simple defuns.
38
(with-upgradability ()
39 40 41
  (defgeneric traverse-actions (actions &key &allow-other-keys))
  (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
  (defgeneric required-components (component &key &allow-other-keys)))
42

43 44

;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
45 46
(with-upgradability ()
  (defun action-path (action)
47
    "A readable data structure that identifies the action."
48 49
    (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
  (defun find-action (path)
50
    "Reconstitute an action from its action-path"
51
    (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
52

53 54

;;;; Convenience methods
55
(with-upgradability ()
56 57 58 59 60 61 62 63 64 65 66
  ;; A macro that defines convenience methods for a gf that dispatches on operation and component.
  ;; The convenience methods allow users to call the gf with operation and/or component designators,
  ;; that the methods will resolve into actual operation and component objects, so that the users
  ;; can interact using readable designators, but developers only have to write methods that handle
  ;; operation and component objects.
  ;; FUNCTION is the function name
  ;; FORMALS its list of arguments, which must include OPERATION and COMPONENT.
  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
  ;; If OPERATION-INITARGS initargs is true, then for backward compatibility the function has
  ;; a &rest argument that is passed into the operation's initargs if and when it is created.
67
  (defmacro define-convenience-action-methods
68
      (function formals &key if-no-operation if-no-component operation-initargs)
69 70
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
71 72 73
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
74 75 76 77 78 79
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
           (prefix (subseq formals 0 opix))
           (suffix (subseq formals (1+ coix) len))
80
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
81
      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
82 83
      (flet ((next-method (o c)
               (if keyp
84 85
                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
                   `(,function ,@prefix ,o ,c ,@suffix))))
86
        `(progn
87 88 89 90
           (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
             (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
               ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
           (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
91 92 93 94 95 96 97
             (if ,operation
                 ,(next-method
                   (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
                       `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
                       `(make-operation ,operation))
                   `(or (find-component () ,component) ,if-no-component))
                 ,if-no-operation))
98
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
99 100 101
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
102 103 104
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
105

106 107

;;;; self-description
108 109 110
(with-upgradability ()
  (defgeneric action-description (operation component)
    (:documentation "returns a phrase that describes performing this operation
111 112
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
113 114 115
  (defmethod action-description (operation component)
    (format nil (compatfmt "~@<~A on ~A~@:>")
            (type-of operation) component))
116 117 118 119 120

  ;; This is for compatibility with ASDF 1, and is deprecated.
  ;; TODO: move it to backward-interface
  (defgeneric* (explain) (operation component)
    (:documentation "Display a message describing an action"))
121 122 123
  (defmethod explain ((o operation) (c component))
    (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
  (define-convenience-action-methods explain (operation component))
124

125
  (defun format-action (stream action &optional colon-p at-sign-p)
126 127
    "FORMAT helper to display an action's action-description.
Use it in FORMAT control strings as ~/asdf-action:format-action/"
128 129 130
    (assert (null colon-p)) (assert (null at-sign-p))
    (destructuring-bind (operation . component) action
      (princ (action-description operation component) stream))))
131 132 133


;;;; Dependencies
134
(with-upgradability ()
135
  (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
136 137
    (:documentation
     "Returns a list of dependencies needed by the component to perform
138 139
    the operation.  A dependency has one of the following forms:

140 141 142 143 144
      (<operation> <component>*), where <operation> is an operation designator
        with respect to FIND-OPERATION in the context of the OPERATION argument,
        and each <component> is a component designator with respect to
        FIND-COMPONENT in the context of the COMPONENT argument,
        and means that the component depends on
145 146 147 148
        <operation> having been performed on each <component>;

        [Note: an <operation> is an operation designator -- it can be either an
        operation name or an operation object.  Similarly, a <component> may be
149 150
        a component name or a component object.  Also note that, the degenerate
        case of (<operation>) is a no-op.]
151

152
    Methods specialized on subclasses of existing component types
153
    should usually append the results of CALL-NEXT-METHOD to the list."))
154
  (define-convenience-action-methods component-depends-on (operation component))
155 156 157

  (defmethod component-depends-on :around ((o operation) (c component))
    (do-asdf-cache `(component-depends-on ,o ,c)
158
      (call-next-method))))
159 160


161 162
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
163 164 165
(with-upgradability ()
  (defclass downward-operation (operation)
    ((downward-operation
166
      :initform nil :reader downward-operation
167
      :type operation-designator :allocation :class))
168 169 170 171 172 173
    (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
174 175
  (defun downward-operation-depends-on (o c)
    `((,(or (downward-operation o) o) ,@(component-children c))))
176
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
177
    `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
178

179 180
  (defclass upward-operation (operation)
    ((upward-operation
181
      :initform nil :reader upward-operation
182
      :type operation-designator :allocation :class))
183 184 185 186 187 188
    (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
must first be prepared for loading or compiling with PREPARE-OP."))
189 190
  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
  ;; so we must guard against this case. ASDF4: remove that.
191 192
  (defun upward-operation-depends-on (o c)
    (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
193
  (defmethod component-depends-on ((o upward-operation) (c child-component))
194
    `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
195

196 197
  (defclass sideway-operation (operation)
    ((sideway-operation
198
      :initform nil :reader sideway-operation
199
      :type operation-designator :allocation :class))
200 201 202 203 204 205
    (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
depends on each of (S . D) where D is a declared dependency of C.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
each of its declared dependencies must first be loaded as by LOAD-OP."))
206
  (defun sideway-operation-depends-on (o c)
207
    `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
208 209
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
210

211 212
  (defclass selfward-operation (operation)
    ((selfward-operation
213
      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
214
      :type (or operation-designator list) :reader selfward-operation :allocation :class))
215
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
216 217
I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
then the action (O . C) of O on component C depends on each (S . C) for S in L.
218
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
219 220
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
221 222 223
NIL is not a valid operation designator in that context.  Note that any dependency
ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
224 225
  (defun selfward-operation-depends-on (o c)
    (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
226
  (defmethod component-depends-on ((o selfward-operation) (c component))
227
    `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
228 229 230

  (defclass non-propagating-operation (operation)
    ()
231
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
232 233 234 235 236 237 238 239
no dependencies whatsoever.  It is supplied in order that the programmer be able
to specify that s/he is intentionally specifying an operation which invokes no
dependencies.")))


;;;---------------------------------------------------------------------------
;;; Help programmers catch obsolete OPERATION subclasses
;;;---------------------------------------------------------------------------
240 241 242 243 244 245 246 247 248 249 250
(with-upgradability ()
  (define-condition operation-definition-warning (simple-warning)
    ()
    (:documentation "Warning condition related to definition of obsolete OPERATION objects."))

  (define-condition operation-definition-error (simple-error)
    ()
    (:documentation "Error condition related to definition of incorrect OPERATION objects."))

  (defmethod initialize-instance :before ((o operation) &key)
    (unless (typep o '(or downward-operation upward-operation sideway-operation
251
                          selfward-operation non-propagating-operation))
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
      (warn 'operation-definition-warning
            :format-control
            "No dependency propagating scheme specified for operation class ~S.
The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
            :format-arguments (list (type-of o)))))

  (defmethod initialize-instance :before ((o non-propagating-operation) &key)
    (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
      (error 'operation-definition-error
             :format-control
             "Inconsistent class: ~S
  NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
             :format-arguments
             (list (type-of o)))))

  (defmethod component-depends-on ((o operation) (c component))
    `(;; Normal behavior, to allow user-specified in-order-to dependencies
      ,@(cdr (assoc (type-of o) (component-in-order-to c)))
      ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
      ;; or non-propagation through an appropriate mixin will be downward and sideway.
      ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
273
                              selfward-operation non-propagating-operation))
274 275
          `(,@(sideway-operation-depends-on o c)
            ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
276 277 278 279

  (defmethod downward-operation ((o operation)) nil)
  (defmethod sideway-operation ((o operation)) nil))

280 281 282 283

;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
284 285 286


;;;; Inputs, Outputs, and invisible dependencies
287
(with-upgradability ()
288 289 290 291 292 293 294 295 296 297 298 299 300 301
  (defgeneric* (output-files) (operation component)
    (:documentation "Methods of this function return two values: a list of output files
corresponding to this action, and a boolean indicating if they have already been subjected
to relevant output translations and should not be further translated.

Methods on PERFORM *must* call this gf to determine where their outputs are to be located.
They may rely on the order of the files to discriminate between outputs.
"))
  (defgeneric* (input-files) (operation component)
    (:documentation "A list of input files corresponding to this action.

Methods on PERFORM *must* call this gf to determine where their inputs are located.
They may rely on the order of the files to discriminate between inputs.
"))
302
  (defgeneric* (operation-done-p) (operation component)
303
    (:documentation "Returns a boolean which is NIL if the action is forced to be performed again"))
304 305 306 307 308 309 310
  (define-convenience-action-methods output-files (operation component))
  (define-convenience-action-methods input-files (operation component))
  (define-convenience-action-methods operation-done-p (operation component))

  (defmethod operation-done-p ((o operation) (c component))
    t)

311
  ;; Translate output files, unless asked not to. Memoize the result.
312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
  (defmethod output-files :around (operation component)
    operation component ;; hush genera, not convinced by declare ignorable(!)
    (do-asdf-cache `(output-files ,operation ,component)
      (values
       (multiple-value-bind (pathnames fixedp) (call-next-method)
         ;; 1- Make sure we have absolute pathnames
         (let* ((directory (pathname-directory-pathname
                            (component-pathname (find-component () component))))
                (absolute-pathnames
                  (loop
                    :for pathname :in pathnames
                    :collect (ensure-absolute-pathname pathname directory))))
           ;; 2- Translate those pathnames as required
           (if fixedp
               absolute-pathnames
               (mapcar *output-translation-function* absolute-pathnames))))
       t)))
  (defmethod output-files ((o operation) (c component))
    nil)
  (defun output-file (operation component)
    "The unique output file of performing OPERATION on COMPONENT"
    (let ((files (output-files operation component)))
      (assert (length=n-p files 1))
      (first files)))

337
  ;; Memoize input files.
338 339 340 341
  (defmethod input-files :around (operation component)
    (do-asdf-cache `(input-files ,operation ,component)
      (call-next-method)))

342
  ;; By default an action has no input-files.
343
  (defmethod input-files ((o operation) (c component))
344 345
    nil)

346 347 348 349
  ;; An action with a selfward-operation by default gets its input-files from the output-files of
  ;; the actions using selfward-operations it depends on (and the same component),
  ;; or if there are none, on the component-pathname of the component if it's a file
  ;; -- and then on the results of the next-method.
350 351 352 353 354 355
  (defmethod input-files ((o selfward-operation) (c component))
    `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
                  :append (or (output-files dep-o c) (input-files dep-o c)))
            (if-let ((pathname (component-pathname c)))
              (and (file-pathname-p pathname) (list pathname))))
      ,@(call-next-method))))
356 357 358


;;;; Done performing
359
(with-upgradability ()
360 361 362 363 364
  ;; ASDF4: hide it behind plan-action-stamp
  (defgeneric component-operation-time (operation component)
    (:documentation "Return the timestamp for when an action was last performed"))
  (defgeneric (setf component-operation-time) (time operation component)
    (:documentation "Update the timestamp for when an action was last performed"))
365
  (define-convenience-action-methods component-operation-time (operation component))
366

367 368 369 370 371 372
  ;; ASDF4: hide it behind (setf plan-action-stamp)
  (defgeneric mark-operation-done (operation component)
    (:documentation "Mark a action as having been just done.

Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
using the JUST-DONE flag."))
373 374
  (defgeneric compute-action-stamp (plan operation component &key just-done)
    (:documentation "Has this action been successfully done already,
375 376
and at what known timestamp has it been done at or will it be done at?
Takes two keywords JUST-DONE and PLAN:
377 378 379 380 381
* JUST-DONE is a boolean that is true if the action was just successfully performed,
  at which point we want compute the actual stamp and warn if files are missing;
  otherwise we are making plans, anticipating the effects of the action.
* PLAN is a plan object modelling future effects of actions,
  or NIL to denote what actually happened.
382 383
Returns two values:
* a STAMP saying when it was done or will be done,
384
  or T if the action involves files that need to be recomputed.
385 386 387
* a boolean DONE-P that indicates whether the action has actually been done,
  and both its output-files and its in-image side-effects are up to date."))

388 389 390 391
  (defclass action-status ()
    ((stamp
      :initarg :stamp :reader action-stamp
      :documentation "STAMP associated with the ACTION if it has been completed already
392
in some previous image, or T if it needs to be done.")
393 394 395 396
     (done-p
      :initarg :done-p :reader action-done-p
      :documentation "a boolean, true iff the action was already done (before any planned action)."))
    (:documentation "Status of an action"))
397

398 399 400 401
  (defmethod print-object ((status action-status) stream)
    (print-unreadable-object (status stream :type t)
      (with-slots (stamp done-p) status
        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
402

403 404
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
405

406 407 408
  (defmethod (setf component-operation-time) (stamp (o operation) (c component))
    (setf (gethash (type-of o) (component-operation-times c)) stamp))

409
  (defmethod mark-operation-done ((o operation) (c component))
410
    (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))
411 412 413


;;;; Perform
414
(with-upgradability ()
415 416
  (defgeneric* (perform) (operation component)
    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
417 418 419 420 421 422 423 424 425
  (define-convenience-action-methods perform (operation component))

  (defmethod perform :before ((o operation) (c component))
    (ensure-all-directories-exist (output-files o c)))
  (defmethod perform :after ((o operation) (c component))
    (mark-operation-done o c))
  (defmethod perform ((o operation) (c parent-component))
    nil)
  (defmethod perform ((o operation) (c source-file))
426 427 428 429 430 431
    ;; For backward compatibility, don't error on operations that don't specify propagation.
    (when (typep o '(or downward-operation upward-operation sideway-operation
                     selfward-operation non-propagating-operation))
      (sysdef-error
       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
       'perform (cons o c))))
432

433 434 435 436 437
  ;; The restarts of the perform-with-restarts variant matter in an interactive context.
  ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
  ;; may call perform directly rather than call p-w-r.
  (defgeneric* (perform-with-restarts) (operation component)
    (:documentation "PERFORM an action in a context where suitable restarts were setup."))
438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
  (defmethod perform-with-restarts (operation component)
    (perform operation component))
  (defmethod perform-with-restarts :around (operation component)
    (loop
      (restart-case
          (return (call-next-method))
        (retry ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Retry ~A.~@:>")
                    (action-description operation component))))
        (accept ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
                    (action-description operation component)))
          (mark-operation-done operation component)
          (return))))))