plan.lisp 28.7 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Plan

4
(uiop/package:define-package :asdf/plan
5
  (:recycle :asdf/plan :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7
   :asdf/component :asdf/operation :asdf/system
8
   :asdf/cache :asdf/find-system :asdf/find-component
9
   :asdf/operation :asdf/action :asdf/lisp-action)
10
  (:export
11
   #:component-operation-time
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
12
   #:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
13 14
   #:planned-action-status #:plan-action-status #:action-already-done-p
   #:circular-dependency #:circular-dependency-actions
15
   #:needed-in-image-p
16
   #:action-index #:action-planned-p #:action-valid-p
17
   #:plan-record-dependency
18
   #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
19
   #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
20
   #:compute-action-stamp #:traverse-action
21
   #:circular-dependency #:circular-dependency-actions
22
   #:call-while-visiting-action #:while-visiting-action
23
   #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
24 25
   #:planned-p #:index #:forced #:forced-not #:total-action-count
   #:planned-action-count #:planned-output-action-count #:visited-actions
26
   #:visiting-action-set #:visiting-action-list #:plan-actions-r
27
   #:required-components #:filtered-sequential-plan
28
   #:plan-system
29 30
   #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
   #:traverse-actions #:traverse-sub-actions))
31
(in-package :asdf/plan)
32

33
;;;; Generic plan traversal class
34
(with-upgradability ()
35 36
  (defclass plan () ()
    (:documentation "Base class for a plan based on which ASDF can build a system"))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
37
  (defclass plan-traversal (plan)
38 39
    (;; The system for which the plan is computed
     (system :initform nil :initarg :system :accessor plan-system)
40
     ;; Table of systems specified via :force arguments
41
     (forced :initform nil :initarg :force :accessor plan-forced)
42
     ;; Table of systems specified via :force-not argument (and/or immutable)
43
     (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
44
     ;; Counts of total actions in plan
45
     (total-action-count :initform 0 :accessor plan-total-action-count)
46
     ;; Count of actions that need to be performed
47
     (planned-action-count :initform 0 :accessor plan-planned-action-count)
48
     ;; Count of actions that need to be performed that have a non-empty list of output-files.
49
     (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
50
     ;; Table that to actions already visited while walking the dependencies associates status
51
     (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
52 53 54 55 56
     ;; 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 plan-visiting-action-set)
     (visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list
    (:documentation "Base class for plans that simply traverse dependencies")))
57 58


59
;;;; Planned action status
60 61 62
(with-upgradability ()
  (defgeneric plan-action-status (plan operation component)
    (:documentation "Returns the ACTION-STATUS associated to
63 64
the action of OPERATION on COMPONENT in the PLAN"))

65 66
  (defgeneric (setf plan-action-status) (new-status plan operation component)
    (:documentation "Sets the ACTION-STATUS associated to
67 68
the action of OPERATION on COMPONENT in the PLAN"))

69 70 71 72 73 74 75 76 77 78 79 80 81 82
  (defclass planned-action-status (action-status)
    ((planned-p
      :initarg :planned-p :reader action-planned-p
      :documentation "a boolean, true iff the action was included in the plan.")
     (index
      :initarg :index :reader action-index
      :documentation "an integer, counting all traversed actions in traversal order."))
    (:documentation "Status of an action in a plan"))

  (defmethod print-object ((status planned-action-status) stream)
    (print-unreadable-object (status stream :type t :identity nil)
      (with-slots (stamp done-p planned-p index) status
        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
83 84
  (defmethod action-planned-p ((action-status t))
    t) ; default method for non planned-action-status objects
85 86

  (defun action-already-done-p (plan operation component)
87
    "According to this plan, is this action already done and up to date?"
88 89 90 91 92 93 94
    (action-done-p (plan-action-status plan operation component)))

  (defmethod plan-action-status ((plan null) (o operation) (c component))
    (multiple-value-bind (stamp done-p) (component-operation-time o c)
      (make-instance 'action-status :stamp stamp :done-p done-p)))

  (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
95
    (let ((times (component-operation-times c)))
96
      (if (action-done-p new-status)
97 98
          (remhash o times)
          (setf (gethash o times) (action-stamp new-status))))
99
    new-status))
100 101 102


;;;; forcing
103
(with-upgradability ()
104 105 106 107 108 109 110 111 112 113 114 115 116
  (defgeneric action-forced-p (plan operation component)
    (:documentation "Is this action forced to happen in this plan?"))
  (defgeneric action-forced-not-p (plan operation component)
    (:documentation "Is this action forced to not happen in this plan?
Takes precedence over action-forced-p."))

  (defun normalize-forced-systems (force system)
    "Given a SYSTEM on which operate is called and the specified FORCE argument,
extract a hash-set of systems that are forced, or a predicate on system names,
or NIL if none are forced, or :ALL if all are."
    (etypecase force
      ((or (member nil :all) hash-table function) force)
      (cons (list-to-hash-set (mapcar #'coerce-name force)))
117 118
      ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))

119 120 121 122
  (defun normalize-forced-not-systems (force-not system)
    "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
or predicate on system names, or NIL if none are forced, or :ALL if all are."
123
    (let ((requested
124 125 126
            (etypecase force-not
              ((or (member nil :all) hash-table function) force-not)
              (cons (list-to-hash-set (mapcar #'coerce-name force-not)))
127 128
              ((eql t) (if system (let ((name (coerce-name system)))
                                    #'(lambda (x) (not (equal x name))))
129
                           :all)))))
130
      (if (and *immutable-systems* requested)
131 132
          #'(lambda (x) (or (call-function requested x)
                            (call-function *immutable-systems* x)))
133 134
          (or *immutable-systems* requested))))

135
  ;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
136
  (defun action-override-p (plan operation component override-accessor)
137 138
    "Given a plan, an action, and a function that given the plan accesses a set of overrides
(i.e. force or force-not), see if the override applies to the current action."
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
139
    (declare (ignore operation))
140 141
    (call-function (funcall override-accessor plan)
                   (coerce-name (component-system (find-component () component)))))
142 143 144 145 146 147

  (defmethod action-forced-p (plan operation component)
    (and
     ;; Did the user ask us to re-perform the action?
     (action-override-p plan operation component 'plan-forced)
     ;; You really can't force a builtin system and :all doesn't apply to it,
148
     ;; except if it's the specifically the system currently being built.
149 150 151 152 153
     (not (let ((system (component-system component)))
            (and (builtin-system-p system)
                 (not (eq system (plan-system plan))))))))

  (defmethod action-forced-not-p (plan operation component)
154 155 156
    ;; Did the user ask us to not re-perform the action?
    ;; NB: force-not takes precedence over force, as it should
    (action-override-p plan operation component 'plan-forced-not))
157

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
158
  (defmethod action-forced-p ((plan null) (operation operation) (component component))
159 160
    nil)

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
161
  (defmethod action-forced-not-p ((plan null) (operation operation) (component component))
162
    nil))
163 164 165


;;;; action-valid-p
166 167 168
(with-upgradability ()
  (defgeneric action-valid-p (plan operation component)
    (:documentation "Is this action valid to include amongst dependencies?"))
169
  ;; :if-feature will invalidate actions on components for which the features don't apply.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
170
  (defmethod action-valid-p ((plan t) (o operation) (c component))
171
    (if-let (it (component-if-feature c)) (featurep it) t))
172
  ;; If either the operation or component was resolved to nil, the action is invalid.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
173 174
  (defmethod action-valid-p ((plan t) (o null) (c t)) nil)
  (defmethod action-valid-p ((plan t) (o t) (c null)) nil)
175 176
  ;; If the plan is null, i.e., we're looking at reality,
  ;; then any action with actual operation and component objects is valid.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
177
  (defmethod action-valid-p ((plan null) (o operation) (c component)) t))
178 179

;;;; Is the action needed in this image?
180 181
(with-upgradability ()
  (defgeneric needed-in-image-p (operation component)
182 183
    (:documentation "Is the action of OPERATION on COMPONENT needed in the current image
to be meaningful, or could it just as well have been done in another Lisp image?"))
184

185 186 187 188 189 190
  (defmethod needed-in-image-p ((o operation) (c component))
    ;; We presume that actions that modify the filesystem don't need be run
    ;; in the current image if they have already been done in another,
    ;; and can be run in another process (e.g. a fork),
    ;; whereas those that don't are meant to side-effect the current image and can't.
    (not (output-files o c))))
191 192 193


;;;; Visiting dependencies of an action and computing action stamps
194
(with-upgradability ()
195
  (defun* (map-direct-dependencies) (plan operation component fun)
196
    "Call FUN on all the valid dependencies of the given action in the given plan"
197
    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
198 199 200 201
           :for dep-o = (find-operation operation dep-o-spec)
           :when dep-o
           :do (loop :for dep-c-spec :in dep-c-specs
                     :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
202
                     :when (and dep-c (action-valid-p plan dep-o dep-c))
203
                       :do (funcall fun dep-o dep-c))))
204

205
  (defun* (reduce-direct-dependencies) (plan operation component combinator seed)
206 207 208
    "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
for each dependency action on the dependency's operation and component and an accumulator
initialized with SEED."
209
    (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
210
     plan operation component
211 212 213 214
     #'(lambda (dep-o dep-c)
         (setf seed (funcall combinator dep-o dep-c seed))))
    seed)

215
  (defun* (direct-dependencies) (plan operation component)
216
    "Compute a list of the direct dependencies of the action within the plan"
217
    (reverse (reduce-direct-dependencies plan operation component #'acons nil)))
218

219 220 221 222
  ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
  ;; shall also be parametrized by the plan, or by a second model object,
  ;; so they need not refer to the state of the filesystem,
  ;; and the stamps could be cryptographic checksums rather than timestamps.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
223
  ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
224 225

  (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
226 227 228 229 230 231 232 233 234
    ;; Given an action, figure out at what time in the past it has been done,
    ;; or if it has just been done, return the time that it has.
    ;; Returns two values:
    ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
    ;;   or T is either hasn't been done or is out of date.
    ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
    ;;   in the current image, or NIL if it hasn't.
    ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
    ;; hasn't been done in the current image yet, then it can have a non-T timestamp,
235 236
    ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
    ;; i.e. that of the input-files.
237 238 239
    (nest
     (block ())
     (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
240 241 242 243 244 245 246
             (reduce-direct-dependencies
              plan o c
              #'(lambda (o c stamp)
                  (if-let (it (plan-action-status plan o c))
                    (latest-stamp stamp (action-stamp it))
                    t))
              nil)))
247 248 249 250 251 252 253 254 255
       ;; out-of-date dependency: don't bother expensively querying the filesystem
       (when (and (eq dep-stamp t) (not just-done)) (return (values t nil))))
     ;; collect timestamps from inputs, and exit early if any is missing
     (let* ((in-files (input-files o c))
            (in-stamps (mapcar #'get-file-stamp in-files))
            (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
            (latest-in (stamps-latest (cons dep-stamp in-stamps))))
       (when (and missing-in (not just-done)) (return (values t nil))))
     ;; collect timestamps from outputs, and exit early if any is missing
256
     (let* ((out-files (remove-if 'null (output-files o c)))
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292
            (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
            (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
            (earliest-out (stamps-earliest out-stamps)))
       (when (and missing-out (not just-done)) (return (values t nil))))
     (let* (;; There are three kinds of actions:
            (out-op (and out-files t)) ; those that create files on the filesystem
            ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
            ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
            ;; When was the thing last actually done? (Now, or ask.)
            (op-time (or just-done (component-operation-time o c)))
            ;; Time stamps from the files at hand, and whether any is missing
            (all-present (not (or missing-in missing-out)))
            ;; Has any input changed since we last generated the files?
            (up-to-date-p (stamp<= latest-in earliest-out))
            ;; If everything is up to date, the latest of inputs and outputs is our stamp
            (done-stamp (stamps-latest (cons latest-in out-stamps))))
       ;; Warn if some files are missing:
       ;; either our model is wrong or some other process is messing with our files.
       (when (and just-done (not all-present))
         (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
                ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
               (action-description o c)
               missing-in (length missing-in) (and missing-in missing-out)
               missing-out (length missing-out))))
     ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
     ;; Any race condition is intrinsic to the limited timestamp resolution.
     (if (or just-done ;; The done-stamp is valid: if we're just done, or
             ;; if all filesystem effects are up-to-date and there's no invalidating reason.
             (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
         (values done-stamp ;; return the hard-earned timestamp
                 (or just-done
                     out-op ;; a file-creating op is done when all files are up to date
                     ;; a image-effecting a placeholder op is done when it was actually run,
                     (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
         ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
         (values t nil)))))
293 294


295 296 297
;;;; Generic support for plan-traversal
(with-upgradability ()
  (defmethod initialize-instance :after ((plan plan-traversal)
298
                                         &key force force-not system
299 300
                                         &allow-other-keys)
    (with-slots (forced forced-not) plan
301 302
      (setf forced (normalize-forced-systems force system))
      (setf forced-not (normalize-forced-not-systems force-not system))))
303

304 305 306 307 308 309
  (defgeneric plan-actions (plan)
    (:documentation "Extract from a plan a list of actions to perform in sequence"))
  (defmethod plan-actions ((plan list))
    plan)

  (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component))
310
    (setf (gethash (cons o c) (plan-visited-actions p)) new-status))
311 312 313

  (defmethod plan-action-status ((p plan-traversal) (o operation) (c component))
    (or (and (action-forced-not-p p o c) (plan-action-status nil o c))
314
        (values (gethash (cons o c) (plan-visited-actions p)))))
315

316 317
  (defmethod action-valid-p ((p plan-traversal) (o operation) (s system))
    (and (not (action-forced-not-p p o s)) (call-next-method)))
318

319 320 321 322 323 324 325 326 327 328 329 330 331 332
  (defgeneric plan-record-dependency (plan operation component)
    (:documentation "Record an action as a dependency in the current plan")))


;;;; Detection of circular dependencies
(with-upgradability ()
  (define-condition circular-dependency (system-definition-error)
    ((actions :initarg :actions :reader circular-dependency-actions))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
                       (circular-dependency-actions c)))))

  (defgeneric call-while-visiting-action (plan operation component function)
    (:documentation "Detect circular dependencies"))
333 334 335 336

  (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
    (with-accessors ((action-set plan-visiting-action-set)
                     (action-list plan-visiting-action-list)) plan
337
      (let ((action (make-action operation component)))
338 339 340 341 342 343 344 345
        (when (gethash action action-set)
          (error 'circular-dependency :actions
                 (member action (reverse action-list) :test 'equal)))
        (setf (gethash action action-set) t)
        (push action action-list)
        (unwind-protect
             (funcall fun)
          (pop action-list)
346 347 348 349 350
          (setf (gethash action action-set) nil)))))

  ;; Syntactic sugar for call-while-visiting-action
  (defmacro while-visiting-action ((p o c) &body body)
    `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))))
351 352 353


;;;; Actual traversal: traverse-action
354 355 356
(with-upgradability ()
  (defgeneric traverse-action (plan operation component needed-in-image-p))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
357 358 359 360 361 362 363 364
  ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
  ;; visits the action defined by its OPERATION and COMPONENT arguments,
  ;; and all its transitive dependencies (unless already visited),
  ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
  ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
  ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action
  ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension),
  ;; or T if the action needs to be done again.
365 366 367 368 369
  ;;
  ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
  ;; the below method would be insufficient, since it assumes a single image
  ;; to traverse each node at most twice; non-niip actions would be traversed only once,
  ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
370

371 372
  (defmethod traverse-action (plan operation component needed-in-image-p)
    (block nil
373 374
      ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT,
      ;; and IF-FEATURE filtering.
375
      (unless (action-valid-p plan operation component) (return nil))
376
      ;; the following hook is needed by POIU, which tracks a full dependency graph,
377
      ;; instead of just a dependency order as in vanilla ASDF
378
      (plan-record-dependency plan operation component)
379
      ;; needed in image distinguishes b/w things that must happen in the
380 381 382
      ;; current image and those things that simply need to have been done in a previous one.
      (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
             ;; effective niip: meaningful for the action and required by the plan as traversed
383
             (eniip (and aniip needed-in-image-p))
384
             ;; status: have we traversed that action previously, and if so what was its status?
385 386
             (status (plan-action-status plan operation component)))
        (when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
387 388
          (return (action-stamp status))) ; Already visited with sufficient need-in-image level!
        (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
389 390
                   (map-direct-dependencies ; recursively traverse dependencies
                    plan operation component #'(lambda (o c) (traverse-action plan o c niip)))
391 392
                   (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed,
                       (compute-action-stamp plan operation component) ; compute action stamp
393
                     (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
394 395 396
                       (cond ; it needs be done if it's out of date or needed in image but absent
                         ((and add-to-plan-p (not niip)) ; if we need to do it,
                          (visit-action t)) ; then we need to do it *in the (current) image*!
397
                         (t
398
                          (setf (plan-action-status plan operation component) ; update status:
399 400
                                (make-instance
                                 'planned-action-status
401 402 403 404 405 406
                                 :stamp stamp ; computed stamp
                                 :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date?
                                 :planned-p add-to-plan-p ; included in list of things to be done?
                                 :index (if status ; index of action amongst all nodes in traversal
                                            (action-index status) ;; if already visited, keep index
                                            (incf (plan-total-action-count plan))))) ; else new index
407 408
                          (when (and done-p (not add-to-plan-p))
                            (setf (component-operation-time operation component) stamp))
409 410 411 412 413
                          (when add-to-plan-p ; if it needs to be added to the plan,
                            (incf (plan-planned-action-count plan)) ; count it
                            (unless aniip ; if it's output-producing,
                              (incf (plan-planned-output-action-count plan)))) ; count it
                          stamp)))))) ; return the stamp
414
          (while-visiting-action (plan operation component) ; maintain context, handle circularity.
415
            (visit-action eniip))))))) ; visit the action
416 417 418


;;;; Sequential plans (the default)
419 420
(with-upgradability ()
  (defclass sequential-plan (plan-traversal)
421 422
    ((actions-r :initform nil :accessor plan-actions-r))
    (:documentation "Simplest, default plan class, accumulating a sequence of actions"))
423

424 425
  (defmethod plan-actions ((plan sequential-plan))
    (reverse (plan-actions-r plan)))
426

427
  ;; No need to record a dependency to build a full graph, just accumulate nodes in order.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
428
  (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component))
429
    (values))
430

431 432 433
  (defmethod (setf plan-action-status) :after
      (new-status (p sequential-plan) (o operation) (c component))
    (when (action-planned-p new-status)
434
      (push (make-action o c) (plan-actions-r p)))))
435

436

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
437
;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
438
(with-upgradability ()
439
  (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
440
    (:documentation "Generate and return a plan for performing OPERATION on COMPONENT."))
441 442
  (define-convenience-action-methods make-plan (plan-class operation component &key))

443 444 445 446
  (defgeneric perform-plan (plan &key)
    (:documentation "Actually perform a plan and build the requested actions"))
  (defgeneric plan-operates-on-p (plan component)
    (:documentation "Does this PLAN include any operation on given COMPONENT?"))
447

448 449
  (defvar *default-plan-class* 'sequential-plan
    "The default plan class to use when building with ASDF")
450

451
  (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
452
    (let ((plan (apply 'make-instance (or plan-class *default-plan-class*)
453
                       :system (component-system c) keys)))
454
      (traverse-action plan o c t)
455
      plan))
456

457
  (defmethod perform-plan :around ((plan t) &key)
458
    #+xcl (declare (ignorable plan))
459 460 461 462
    (let ((*package* *package*)
          (*readtable* *readtable*))
      (with-compilation-unit () ;; backward-compatibility.
        (call-next-method))))   ;; Going forward, see deferred-warning support in lisp-build.
463

464 465 466
  (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
    (apply 'perform-plan (plan-actions plan) keys))

467
  (defmethod perform-plan ((steps list) &key force &allow-other-keys)
468 469 470
    (loop* :for action :in steps
           :as o = (action-operation action)
           :as c = (action-component action)
471 472
           :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
           :do (perform-with-restarts o c)))
473

474 475 476
  (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
    (plan-operates-on-p (plan-actions plan) component-path))

477
  (defmethod plan-operates-on-p ((plan list) (component-path list))
478
    (find component-path (mapcar 'action-component plan)
479
          :test 'equal :key 'component-find-path)))
480

481

482
;;;; Incidental traversals
483 484 485

;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
;;; files required by a bundling operation.
486 487 488 489 490
(with-upgradability ()
  (defclass filtered-sequential-plan (sequential-plan)
    ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
     (component-type :initform t :initarg :component-type :reader plan-component-type)
     (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
491 492
     (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
    (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
493 494

  (defmethod initialize-instance :after ((plan filtered-sequential-plan)
495
                                         &key force force-not
496
                                         other-systems)
497
    (declare (ignore force force-not))
498 499 500
    ;; Ignore force and force-not, rely on other-systems:
    ;; force traversal of what we're interested in, i.e. current system or also others;
    ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
501
    (with-slots (forced forced-not action-filter system) plan
502 503
      (setf forced (normalize-forced-systems (if other-systems :all t) system))
      (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))
504 505 506 507 508 509 510
      (setf action-filter (ensure-function action-filter))))

  (defmethod action-valid-p ((plan filtered-sequential-plan) o c)
    (and (funcall (plan-action-filter plan) o c)
         (typep c (plan-component-type plan))
         (call-next-method)))

511
  (defun* (traverse-actions) (actions &rest keys &key plan-class &allow-other-keys)
512
    "Given a list of actions, build a plan with these actions as roots."
513
    (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
514 515 516 517
      (loop* :for action :in actions
             :as o = (action-operation action)
             :as c = (action-component action)
             :do (traverse-action plan o c t))
518
      plan))
519

520
  (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
521
  (define-convenience-action-methods traverse-sub-actions (operation component &key))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
522 523 524
  (defmethod traverse-sub-actions ((operation operation) (component component)
                                   &rest keys &key &allow-other-keys)
    (apply 'traverse-actions (direct-dependencies t operation component)
525 526 527 528
           :system (component-system component) keys))

  (defmethod plan-actions ((plan filtered-sequential-plan))
    (with-slots (keep-operation keep-component) plan
529 530 531
      (loop* :for action :in (call-next-method)
             :as o = (action-operation action)
             :as c = (action-component action)
532
             :when (and (typep o keep-operation) (typep c keep-component))
533
             :collect (make-action o c))))
534

535
  (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
536 537
    "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
return a list of the components involved in building the desired action."
538
    (remove-duplicates
539 540 541 542
     (mapcar 'action-component
             (plan-actions
              (apply 'traverse-sub-actions goal-operation system
                     (remove-plist-key :goal-operation keys))))
543
     :from-end t)))
544