action.lisp 22.5 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
  (:import-from :asdf/operation #:check-operation-constructor)
10
  (:export
11
   #:action #:define-convenience-action-methods
12
   #:action-description
13
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
14
   #:component-depends-on
15
16
17
   #: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
18
   #:perform #:perform-with-restarts #:retry #:accept
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

;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
38
39
(with-upgradability ()
  (defun action-path (action)
40
    "A readable data structure that identifies the action."
41
42
    (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
  (defun find-action (path)
43
    "Reconstitute an action from its action-path"
44
    (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
45

46
47

;;;; Convenience methods
48
(with-upgradability ()
49
50
51
52
53
54
55
56
  ;; A macro that defines convenience methods for a generic function (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 generic function name
  ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
57
58
  ;; 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.
59
  ;; If OPERATION-INITARGS is true, then for backward compatibility the function has
60
  ;; a &rest argument that is passed into the operation's initargs if and when it is created.
61
  (defmacro define-convenience-action-methods
62
      (function formals &key if-no-operation if-no-component operation-initargs)
63
64
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
65
66
67
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
68
69
70
71
72
73
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
           (prefix (subseq formals 0 opix))
           (suffix (subseq formals (1+ coix) len))
74
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
75
      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
76
77
      (flet ((next-method (o c)
               (if keyp
78
79
                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
                   `(,function ,@prefix ,o ,c ,@suffix))))
80
        `(progn
81
82
83
84
           (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)
85
86
87
88
89
90
91
             (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))
92
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
93
94
95
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
96
97
98
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
99

100
101

;;;; self-description
102
103
104
(with-upgradability ()
  (defgeneric action-description (operation component)
    (:documentation "returns a phrase that describes performing this operation
105
106
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
107
108
109
  (defmethod action-description (operation component)
    (format nil (compatfmt "~@<~A on ~A~@:>")
            (type-of operation) component))
110

111
  (defun format-action (stream action &optional colon-p at-sign-p)
112
113
    "FORMAT helper to display an action's action-description.
Use it in FORMAT control strings as ~/asdf-action:format-action/"
114
115
116
    (assert (null colon-p)) (assert (null at-sign-p))
    (destructuring-bind (operation . component) action
      (princ (action-description operation component) stream))))
117
118
119


;;;; Dependencies
120
(with-upgradability ()
121
  (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
122
123
    (:documentation
     "Returns a list of dependencies needed by the component to perform
124
125
    the operation.  A dependency has one of the following forms:

126
127
128
129
130
      (<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
131
132
133
134
        <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
135
136
        a component name or a component object.  Also note that, the degenerate
        case of (<operation>) is a no-op.]
137

138
    Methods specialized on subclasses of existing component types
139
    should usually append the results of CALL-NEXT-METHOD to the list."))
140
  (define-convenience-action-methods component-depends-on (operation component))
141
142
143

  (defmethod component-depends-on :around ((o operation) (c component))
    (do-asdf-cache `(component-depends-on ,o ,c)
144
      (call-next-method))))
145
146


147
148
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
149
150
151
(with-upgradability ()
  (defclass downward-operation (operation)
    ((downward-operation
152
      :initform nil :reader downward-operation
153
      :type operation-designator :allocation :class))
154
155
156
157
158
159
    (: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."))
160
161
  (defun downward-operation-depends-on (o c)
    `((,(or (downward-operation o) o) ,@(component-children c))))
162
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
163
    `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
164

165
166
  (defclass upward-operation (operation)
    ((upward-operation
167
      :initform nil :reader upward-operation
168
      :type operation-designator :allocation :class))
169
170
171
172
173
174
    (: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."))
175
176
  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
  ;; so we must guard against this case. ASDF4: remove that.
177
178
  (defun upward-operation-depends-on (o c)
    (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
179
  (defmethod component-depends-on ((o upward-operation) (c child-component))
180
    `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
181

182
183
  (defclass sideway-operation (operation)
    ((sideway-operation
184
      :initform nil :reader sideway-operation
185
      :type operation-designator :allocation :class))
186
187
188
189
190
191
    (: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."))
192
  (defun sideway-operation-depends-on (o c)
193
    `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
194
195
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
196

197
198
  (defclass selfward-operation (operation)
    ((selfward-operation
199
      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
200
      :type (or operation-designator list) :reader selfward-operation :allocation :class))
201
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
202
203
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.
204
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
205
206
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
207
208
209
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."))
210
211
  (defun selfward-operation-depends-on (o c)
    (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
212
  (defmethod component-depends-on ((o selfward-operation) (c component))
213
    `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
214
215
216

  (defclass non-propagating-operation (operation)
    ()
217
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
218
219
220
221
222
223
224
225
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
;;;---------------------------------------------------------------------------
226
227
228
229
230
231
232
233
234
235
(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)
236
    (check-operation-constructor)
237
    (unless (typep o '(or downward-operation upward-operation sideway-operation
238
                          selfward-operation non-propagating-operation))
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
      (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
260
                              selfward-operation non-propagating-operation))
261
262
          `(,@(sideway-operation-depends-on o c)
            ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
263
264
265
266

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

267
268
269
270

;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
271
272
273


;;;; Inputs, Outputs, and invisible dependencies
274
(with-upgradability ()
275
  (defgeneric output-files (operation component)
276
    (:documentation "Methods for this function return two values: a list of output files
277
278
279
corresponding to this action, and a boolean indicating if they have already been subjected
to relevant output translations and should not be further translated.

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

286
Methods on PERFORM *must* call this function to determine where their inputs are located.
287
288
They may rely on the order of the files to discriminate between inputs.
"))
289
  (defgeneric operation-done-p (operation component)
290
    (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
291
292
293
294
295
296
297
  (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)

298
  ;; Translate output files, unless asked not to. Memoize the result.
299
  (defmethod output-files :around ((operation t) (component t))
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
    (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)))

323
  ;; Memoize input files.
324
325
326
327
  (defmethod input-files :around (operation component)
    (do-asdf-cache `(input-files ,operation ,component)
      (call-next-method)))

328
  ;; By default an action has no input-files.
329
  (defmethod input-files ((o operation) (c component))
330
331
    nil)

332
333
334
335
  ;; 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.
336
337
338
339
340
341
  (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))))
342
343
344


;;;; Done performing
345
(with-upgradability ()
346
347
348
349
350
  ;; 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"))
351
  (define-convenience-action-methods component-operation-time (operation component))
352

353
354
355
356
357
358
  ;; 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."))
359
360
  (defgeneric compute-action-stamp (plan operation component &key just-done)
    (:documentation "Has this action been successfully done already,
361
362
and at what known timestamp has it been done at or will it be done at?
Takes two keywords JUST-DONE and PLAN:
363
364
365
366
367
* 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.
368
369
Returns two values:
* a STAMP saying when it was done or will be done,
370
  or T if the action involves files that need to be recomputed.
371
372
373
* 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."))

374
375
376
377
  (defclass action-status ()
    ((stamp
      :initarg :stamp :reader action-stamp
      :documentation "STAMP associated with the ACTION if it has been completed already
378
in some previous image, or T if it needs to be done.")
379
380
381
382
     (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"))
383

384
385
386
387
  (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))))
388

389
390
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
391

392
393
394
  (defmethod (setf component-operation-time) (stamp (o operation) (c component))
    (setf (gethash (type-of o) (component-operation-times c)) stamp))

395
  (defmethod mark-operation-done ((o operation) (c component))
396
    (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))
397
398
399


;;;; Perform
400
(with-upgradability ()
401
  (defgeneric perform (operation component)
402
    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
403
404
405
406
407
408
409
410
411
  (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))
412
413
414
415
416
417
    ;; 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))))
418

419
420
421
  ;; 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.
422
  (defgeneric perform-with-restarts (operation component)
423
    (:documentation "PERFORM an action in a context where suitable restarts are in place."))
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
  (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))))))