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

(uiop/package:define-package :asdf/action
  (:nicknames :asdf-action)
  (:recycle :asdf/action :asdf)
  (:use :uiop/common-lisp :uiop :asdf/upgrade
   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
   #:action #:define-convenience-action-methods
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
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
   #:perform #:perform-with-restarts #:retry #:accept
   #:action-path #:find-action #:stamp #:done-p
   #:operation-definition-warning #:operation-definition-error ;; condition
21 22
(in-package :asdf/action)

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

  (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))
29 30

  (deftype operation-designator ()
31 32
    "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."
    '(or operation null symbol class)))

35 36

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

45 46

;;;; Convenience methods
(with-upgradability ()
48 49 50 51 52 53 54 55
  ;; 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.
56 57
  ;; 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 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.
  (defmacro define-convenience-action-methods
      (function formals &key if-no-operation if-no-component operation-initargs)
62 63
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
64 65 66
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
67 68 69 70 71 72
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
           (prefix (subseq formals 0 opix))
           (suffix (subseq formals (1+ coix) len))
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
75 76
      (flet ((next-method (o c)
               (if keyp
77 78
                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
                   `(,function ,@prefix ,o ,c ,@suffix))))
80 81 82 83
           (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)
84 85 86 87 88 89 90
             (if ,operation
                   (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))
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
92 93 94
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
95 96 97
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)

99 100

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

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

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

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

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

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

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

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

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

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

  (defclass non-propagating-operation (operation)
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
217 218 219 220 221 222 223 224
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

;;; Help programmers catch obsolete OPERATION subclasses
225 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)
    (unless (typep o '(or downward-operation upward-operation sideway-operation
                          selfward-operation non-propagating-operation))
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
      (warn 'operation-definition-warning
            "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
             "Inconsistent class: ~S
  NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
             (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
                              selfward-operation non-propagating-operation))
259 260
          `(,@(sideway-operation-depends-on o c)
            ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
261 262 263 264

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

265 266 267 268

;;; End of OPERATION class checking
269 270 271

;;;; Inputs, Outputs, and invisible dependencies
(with-upgradability ()
  (defgeneric output-files (operation component)
    (:documentation "Methods for this function return two values: a list of output files
275 276 277
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 function to determine where their outputs are to be located.
279 280
They may rely on the order of the files to discriminate between outputs.
  (defgeneric input-files (operation component)
282 283
    (:documentation "A list of input files corresponding to this action.

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

  ;; Translate output files, unless asked not to. Memoize the result.
  (defmethod output-files :around ((operation t) (component t))
298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
    (do-asdf-cache `(output-files ,operation ,component)
       (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))))
                    :for pathname :in pathnames
                    :collect (ensure-absolute-pathname pathname directory))))
           ;; 2- Translate those pathnames as required
           (if fixedp
               (mapcar *output-translation-function* absolute-pathnames))))
  (defmethod output-files ((o operation) (c component))
  (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)))

  ;; Memoize input files.
322 323 324 325
  (defmethod input-files :around (operation component)
    (do-asdf-cache `(input-files ,operation ,component)

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

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

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

351 352 353 354 355 356
  ;; ASDF4: hide it behind (setf plan-action-stamp)
  (defgeneric mark-operation-done (operation component)
    (:documentation "Mark a action as having been just done.

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

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

382 383 384 385
  (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))))

387 388
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))

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

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

;;;; Perform
(with-upgradability ()
  (defgeneric perform (operation component)
    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
401 402 403 404 405 406 407 408 409
  (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))
  (defmethod perform ((o operation) (c source-file))
410 411 412 413 414 415
    ;; 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))
       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
       'perform (cons o c))))

417 418 419
  ;; 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 are in place."))
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
  (defmethod perform-with-restarts (operation component)
    (perform operation component))
  (defmethod perform-with-restarts :around (operation component)
          (return (call-next-method))
        (retry ()
          (lambda (s)
            (format s (compatfmt "~@<Retry ~A.~@:>")
                    (action-description operation component))))
        (accept ()
          (lambda (s)
            (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
                    (action-description operation component)))
          (mark-operation-done operation component)