poiu.lisp 6.31 KB
Newer Older
1
2
3
(uiop:define-package :poiu
  (:use :uiop/common-lisp :uiop
        :poiu/queue :poiu/fork :poiu/background-process
4
        :asdf/session :asdf/upgrade
5
6
7
8
        :asdf/component :asdf/system :asdf/find-component :asdf/operation
        :asdf/action :asdf/plan :asdf/operate
        :asdf/output-translations)
  (:use-reexport :poiu/action-graph))
9

10
(in-package :poiu)
11
12
13
14
15
16
17
18

;;; Performing a parallel plan
(defun action-result-file (o c)
  (let ((p (component-pathname c)))
    (apply-output-translations
     (make-pathname :name (format nil "~A.ASDF-~A" (file-namestring p) (type-of o))
                    :type "process-result" :defaults p))))

19
(defmethod perform-plan ((plan parallel-plan) &key verbose &allow-other-keys)
20
  (unless (can-fork-or-warn)
21
    (return-from perform-plan (perform-plan (serialize-plan plan))))
22
  (with-slots (starting-points children parents) plan
23
    (let* ((all-deferred-warnings nil)
24
           (planned-output-action-count (planned-output-action-count *asdf-session*))
25
26
27
28
29
30
           (ltogo (unless (zerop planned-output-action-count) (ceiling (log planned-output-action-count 10))))
           (fg-queue (simple-queue))
           (bg-queue (simple-queue)))
      (labels ((background-p (action)
                 (destructuring-bind (o . c) action
                   (not (or (needed-in-image-p o c)
31
                            (action-already-done-p plan o c)))))
32
33
34
35
36
37
38
39
40
41
               (categorize-starting-points ()
                 (loop :for action :in (dequeue-all starting-points) :do
                   (enqueue (if (background-p action) bg-queue fg-queue) action))))
        (categorize-starting-points)
        (doqueue/forking
            (fg-queue bg-queue
             :variables (:item action :backgroundp backgroundp :result result :condition condition)
             :deterministic-order
             (when (plan-deterministic-p plan)
               #'(lambda (action)
42
                   (plan-action-index plan action)))
43
             :announce
44
45
46
             (when verbose
               (destructuring-bind (o . c) action
                 (format t "~&Will ~:[try~;skip~] ~A in ~:[foreground~;background~]~%"
47
                         (action-already-done-p plan o c)
48
                         (action-description o c) backgroundp)))
49
50
51
52
53
             :result-file
             (destructuring-bind (o . c) action (action-result-file o c))
             ;; How we cleanup in the foreground after an action is run
             :cleanup
             (destructuring-bind (o . c) action
54
55
56
               (destructuring-bind (&key deferred-warnings &allow-other-keys) result
                 (when deferred-warnings
                   (push deferred-warnings all-deferred-warnings)))
57
58
59
60
61
62
63
64
               (cond
                 (condition
                  (finish-outputs)
                  (warn "Failed ~A~:[~; in the background~]. Retrying~:*~:[~; in the foreground~]."
                        (action-description o c) backgroundp)
                  (finish-outputs)
                  (perform-with-restarts o c))
                 (t
65
                  (mark-operation-done o c)))
66
67
               (when backgroundp
                 (decf planned-output-action-count)
68
69
                 (asdf-message "~&[~vd to go] Done ~A~%"
                               ltogo planned-output-action-count (action-description o c))
70
71
72
73
74
75
76
                 (finish-outputs))
               (mark-as-done plan o c)
               (categorize-starting-points)))
          ;; What we do in each forked process
          (destructuring-bind (o . c) action
            (cond
              (backgroundp
77
               (perform-with-restarts o c)
78
               `(:deferred-warnings ,(reify-deferred-warnings)))
79
              ((action-already-done-p plan o c)
80
81
82
               (unless (or (not (needed-in-image-p o c))
                           (action-already-done-p nil o c))
                 (warn "WTF? aedp ~A" (action-description o c)))
83
84
85
86
               nil)
              (t
               (perform-with-restarts o c)
               nil))))
87
        (map () #'unreify-deferred-warnings all-deferred-warnings)
88
89
90
91
        (assert (and (empty-p fg-queue) (empty-p bg-queue) (empty-p children))
                (parents children)
                "Problem with the dependency graph: ~A"
                (summarize-plan plan))))))
92
93

;;; Breadcrumbs: feature to replay otherwise non-deterministic builds
94
(defvar *breadcrumb-stream* nil
95
96
97
98
99
100
  "Stream that records the trail of operations on components.
As the order of ASDF operations in general and parallel operations in
particular are randomized, it is necessary to record them to replay &
debug them later.")
(defvar *breadcrumbs* nil
  "Actual breadcrumbs found, to override traversal for replay and debugging")
101

102
(defmethod perform :after (operation component)
103
  "Record the operations and components in a stream of breadcrumbs."
104
  (when *breadcrumb-stream*
105
    (format *breadcrumb-stream* "~S~%" (action-path (cons operation component)))
106
    (force-output *breadcrumb-stream*)))
107
108
109
110

(defun read-breadcrumbs-from (operation pathname)
  (with-open-file (f pathname)
    (loop :for (op . comp) = (read f nil nil) :while op
111
          :collect (cons (find-operation operation op) (find-component () comp)))))
112

113
(defun call-recording-breadcrumbs (pathname record-p thunk)
114
  (if (and record-p (not *breadcrumb-stream*))
115
      (let ((*breadcrumb-stream*
116
117
118
119
120
              (progn
                (delete-file-if-exists pathname)
                (open pathname :direction :output
                               :if-exists :overwrite
                               :if-does-not-exist :create))))
121
122
123
124
        (format *breadcrumb-stream* ";; Breadcrumbs~%")
        (unwind-protect
             (funcall thunk)
          (close *breadcrumb-stream*)))
125
      (funcall thunk)))
126

127
128
129
(defmacro recording-breadcrumbs ((pathname record-p) &body body)
  `(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))

130
(defmethod operate :before ((operation operation) (component t) &key
131
132
133
134
135
                            (breadcrumbs-to nil record-breadcrumbs-p)
                            ((:using-breadcrumbs-from breadcrumb-input-pathname)
                             (make-broadcast-stream) read-breadcrumbs-p)
                            &allow-other-keys)
  (recording-breadcrumbs (breadcrumbs-to record-breadcrumbs-p)
136
    (when read-breadcrumbs-p
137
      (perform-plan (read-breadcrumbs-from operation breadcrumb-input-pathname)))))
138

139
(setf *plan-class* 'parallel-plan)
140