Commit faac30b7 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.32: Make POIU work with ASDF 3.3

Adapt POIU to the significantly refactored ASDF 3.3 code base, whereby
the cache was generalized to a multi-phase session, into which was moved
a lot of data formerly in the plan object.

Do away with reify-action except for pretty printing, and there reuse
ASDF's new equivalent action-path function.
parent 3a26e81b
......@@ -94,14 +94,13 @@ in which case POIU defaults the `*max-forks*` to 16.
Just make sure you use ASDF 3.0.2 or later, and include
Just make sure you use ASDF 3.3.0 or later, and include
`(asdf:load-system :poiu)`
in your build scripts before you build the rest of your software.
It automatically will hook into `asdf::*default-plan-class*`,
though you can reset it.
POIU depends on the new plan-making internals of ASDF 3
as well as on ASDF 3's new UIOP library.
POIU depends on the new plan-making internals of ASDF 3.3.
(uiop:define-package :poiu/action-graph
(:use :uiop/common-lisp :uiop :poiu/queue
:asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/plan)
(:export #:parallel-plan #:*parallel-plan-deterministic-p*
#:summarize-plan #:serialize-plan
#:starting-points #:children #:parents ;; slot names -- FIXME, have clients use accessors
#:plan-starting-points #:plan-children #:plan-parents
#:reify-action #:mark-as-done #:plan-deterministic-p
#:plan-starting-points #:plan-children #:plan-parents #:plan-action-index
#:action-map #:action-map-keys #:action-map-values))
(in-package :poiu/action-graph)
......@@ -25,49 +25,39 @@
:documentation "map an action to a (hash)set of \"parents\" that depend on it")
:initform (make-array '(0) :adjustable t :fill-pointer 0) :reader plan-all-actions)
:initform (make-hash-table :test #'equal) :reader plan-action-indices
:documentation "inverting the all-actions table")
:initform *parallel-plan-deterministic-p* :initarg :deterministic-p
:type boolean :reader plan-deterministic-p
:documentation "is this plan supposed to be executed in deterministic way?")))
(defgeneric plan-action-index (plan action))
(defmethod plan-action-index ((plan parallel-plan) action)
(gethash action (plan-action-indices plan)))
#| ;; We can't do that if we want to trace action-already-done-p
(defmethod print-object ((plan parallel-plan) stream)
(print-unreadable-object (plan stream :type t :identity t)
(with-safe-io-syntax (:package :asdf)
(format stream "~A" (coerce-name (plan-system plan)))
#|(pprint (summarize-plan plan) stream)|#)))
(defmethod plan-operates-on-p ((plan parallel-plan) (component-path list))
(with-slots (starting-points children) plan
(let ((component (find-component () component-path)))
(remove component (append (queue-contents starting-points)
(mapcar 'node-action (action-map-keys children)))
:key 'cdr :test-not 'eq))))
(defun action-node (action)
(destructuring-bind (o . c) action
(check-type o operation)
(check-type c component)
(cons (type-of o) c)))
(defun node-action (node)
(destructuring-bind (oc . c) node
(check-type oc symbol)
(check-type c component)
(cons (make-operation oc) c)))
(pprint (summarize-plan plan) stream))))
(defun make-action-map ()
(make-hash-table :test 'equal))
(defun action-map (map action)
(gethash (action-node action) map))
(gethash action map))
(defun action-unmap (map action)
(remhash (action-node action) map))
(remhash action map))
(defun (setf action-map) (value map action)
(setf (gethash (action-node action) map) value))
(setf (gethash action map) value))
(defun action-map-values (map)
(table-values map))
(defun action-map-keys (map)
(mapcar 'node-action (table-keys map)))
(table-keys map))
(defun record-dependency (parent child parents children)
(defun record-action-dependency (parent child parents children)
(unless (action-map parents child)
(setf (action-map parents child) (make-action-map)))
(when parent
......@@ -76,10 +66,9 @@
(setf (action-map (action-map children parent) child) t)
(setf (action-map (action-map parents child) parent) t)))
(defun mark-as-done (plan operation component)
(defun parallel-plan-mark-as-done (plan operation component)
;; marks the action of operation on component as done in the deps hash-tables,
;; returns a list of new actions that are enabled by it being done.
(check-type operation operation)
(with-slots (starting-points parents children) plan
(let* ((action (cons operation component))
(action-parents (if-let (it (action-map parents action))
......@@ -111,56 +100,52 @@
(enqueue-in-front starting-points enabled-action)))
(values enabled-parents forlorn-children)))))
(defmethod plan-record-dependency ((plan parallel-plan) (o operation) (c component))
(with-slots (children parents visiting-action-list) plan
(let ((action (cons o c))
(parent (first visiting-action-list)))
(record-dependency parent action parents children))))
(defmethod mark-as-done :after ((plan parallel-plan) (operation operation) (component component))
(parallel-plan-mark-as-done plan operation component))
(defmethod (setf plan-action-status) :before
(defmethod record-dependency ((plan parallel-plan) (o operation) (c component))
(let ((action (make-action o c))
(parent (first (visiting-action-list *asdf-session*))))
;; Only record the dependency if it points to a parent in the current plan.
(when (and parent (plan-action-index plan action))
(record-action-dependency parent action (plan-parents plan) (plan-children plan)))))
(defmethod (setf action-status) :before
(new-status (p parallel-plan) (o operation) (c component))
(declare (ignorable new-status))
(unless (gethash (node-for o c) (asdf/plan::plan-visited-actions p)) ; already visited?
(let ((action (cons o c)))
(let ((action (make-action o c)))
(unless (gethash action (visited-actions *asdf-session*)) ; already visited?
(setf (gethash action (plan-action-indices p)) (fill-pointer (plan-all-actions p)))
(vector-push-extend action (plan-all-actions p))
(when (empty-p (action-map (plan-children p) action))
(enqueue (plan-starting-points p) action)))))
(defun reify-action (action)
(destructuring-bind (o . c) action
(check-type o operation)
(check-type c component)
(cons (type-of o) (component-find-path c))))
(defun summarize-plan (plan)
(with-slots (starting-points children) plan
,(loop :for action :in (queue-contents starting-points)
:collect (reify-action action)))
,(mapcar 'action-path (queue-contents starting-points)))
,(mapcar #'rest
(loop :for parent-node :being :the :hash-keys :in children
:using (:hash-value progeny)
:for parent = (node-action parent-node)
:for parent = parent-node
:for (o . c) = parent
:collect `(,(action-index (plan-action-status plan o c))
,(reify-action parent)
:collect `(,(plan-action-index plan parent)
,(action-path parent)
,(if (action-already-done-p plan o c) :- :+)
,@(loop :for child-node :being :the :hash-keys :in progeny
:using (:hash-value v)
:for child = (node-action child-node)
:when v :collect (reify-action child))))
:for child = child-node
:when v :collect (action-path child))))
#'< :key #'first))))))
(defgeneric serialize-plan (plan))
(defmethod serialize-plan ((plan list)) plan)
(defmethod serialize-plan ((plan parallel-plan))
(with-slots (all-actions visited-actions) plan
(loop :for action :in (reverse (coerce all-actions 'list))
(with-slots (all-actions) plan
(loop :for action :in (plan-actions plan)
:for (o . c) = action
:for status = (plan-action-status plan o c)
:when (action-planned-p status) :collect action)))
:when (status-need-p (action-status plan o c)) :collect action)))
(defgeneric check-invariants (object))
......@@ -174,12 +159,13 @@
(mark-as-done plan operation component)))
(unless (empty-p children)
(error "Cycle detected in the dependency graph:~%~S"
(summarize-plan plan))))))
(defmethod make-plan :around (plan-class (o operation) (c component) &key &allow-other-keys)
(let ((plan (call-next-method)))
(warn "~S" (summarize-plan plan))
(when (typep plan 'parallel-plan)
;; make a plan once already and destructively check it
;; make a second plan and destructively check it
(check-invariants (call-next-method)))
......@@ -88,7 +88,7 @@
:data data)))))
(defun call-queue/forking (fun fg-queue bg-queue
&key announce cleanup result-file deterministic-order)
&key announce cleanup result-file deterministic-order)
;; assumes a single-threaded parent process
(declare (optimize debug))
(let ((processes (make-hash-table :test 'equal)))
......@@ -48,7 +48,7 @@
(and ncpus (ignore-errors (parse-integer ncpus :junk-allowed t)))))
(defparameter *max-forks* (or (ncpus) 16)) ; limit how parallel we will try to be.
(defparameter *max-actual-forks* nil) ; record how parallel we actually went.
(defparameter *max-actual-forks* 0) ; record how parallel we actually went.
#+(and sbcl os-unix)
......@@ -7,12 +7,12 @@
POIU will notably compile each Lisp file in its own forked process,
in parallel with other operations (compilation or loading).
However, it will load FASLs serially as they become available."
:depends-on ((:version "asdf" "3.0.2")
(:feature (:and :sbcl :os-unix) "sb-posix"))
:version "1.31.1"
:depends-on ((:version "asdf" "3.3.0")
(:feature (:and :sbcl :os-unix) (:require :sb-posix)))
:version "1.32"
((:file "queue")
(:file "fork")
(:file "action-graph" :depends-on ("queue"))
(:file "background-process" :depends-on ("queue" "fork"))
(:file "action-graph" :depends-on ("queue"))
(:file "poiu" :depends-on ("action-graph" "background-process"))))
(uiop:define-package :poiu
(:use :uiop/common-lisp :uiop
:poiu/queue :poiu/fork :poiu/background-process
:asdf/session :asdf/upgrade
:asdf/component :asdf/system :asdf/find-component :asdf/operation
:asdf/action :asdf/plan :asdf/operate
......@@ -16,23 +16,19 @@
(make-pathname :name (format nil "~A.ASDF-~A" (file-namestring p) (type-of o))
:type "process-result" :defaults p))))
(defun action-effectively-done-p (plan operation component &key force)
(or (action-already-done-p plan operation component)
(and (not force)
(nth-value 1 (compute-action-stamp nil operation component)))))
(defmethod perform-plan ((plan parallel-plan) &key force verbose &allow-other-keys)
(defmethod perform-plan ((plan parallel-plan) &key verbose &allow-other-keys)
(unless (can-fork-or-warn)
(return-from perform-plan (perform-plan (serialize-plan plan))))
(with-slots (starting-points children parents planned-output-action-count) plan
(with-slots (starting-points children parents) plan
(let* ((all-deferred-warnings nil)
(planned-output-action-count (planned-output-action-count *asdf-session*))
(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)
(action-effectively-done-p plan o c :force force)))))
(action-already-done-p plan o c)))))
(categorize-starting-points ()
(loop :for action :in (dequeue-all starting-points) :do
(enqueue (if (background-p action) bg-queue fg-queue) action))))
......@@ -43,20 +39,21 @@
(when (plan-deterministic-p plan)
#'(lambda (action)
(destructuring-bind (o . c) action
(action-index (plan-action-status plan o c)))))
(plan-action-index plan action)))
(when verbose
(destructuring-bind (o . c) action
(format t "~&Will ~:[try~;skip~] ~A in ~:[foreground~;background~]~%"
(action-effectively-done-p plan o c :force force)
(action-already-done-p plan o c)
(action-description o c) backgroundp)))
(destructuring-bind (o . c) action (action-result-file o c))
;; How we cleanup in the foreground after an action is run
(destructuring-bind (o . c) action
(push (getf result :deferred-warnings) all-deferred-warnings)
(destructuring-bind (&key deferred-warnings &allow-other-keys) result
(when deferred-warnings
(push deferred-warnings all-deferred-warnings)))
......@@ -65,8 +62,7 @@
(perform-with-restarts o c))
(mark-operation-done o c)
(destructuring-bind (&key &allow-other-keys) result)))
(mark-operation-done o c)))
(when backgroundp
(decf planned-output-action-count)
(asdf-message "~&[~vd to go] Done ~A~%"
......@@ -80,7 +76,7 @@
(perform-with-restarts o c)
`(:deferred-warnings ,(reify-deferred-warnings)))
((action-effectively-done-p plan o c)
((action-already-done-p plan o c)
(unless (or (not (needed-in-image-p o c))
(action-already-done-p nil o c))
(warn "WTF? aedp ~A" (action-description o c)))
......@@ -88,7 +84,7 @@
(perform-with-restarts o c)
(mapc #'unreify-deferred-warnings all-deferred-warnings)
(map () #'unreify-deferred-warnings all-deferred-warnings)
(assert (and (empty-p fg-queue) (empty-p bg-queue) (empty-p children))
(parents children)
"Problem with the dependency graph: ~A"
......@@ -106,7 +102,7 @@ debug them later.")
(defmethod perform :after (operation component)
"Record the operations and components in a stream of breadcrumbs."
(when *breadcrumb-stream*
(format *breadcrumb-stream* "~S~%" (reify-action (cons operation component)))
(format *breadcrumb-stream* "~S~%" (action-path (cons operation component)))
(force-output *breadcrumb-stream*)))
(defun read-breadcrumbs-from (operation pathname)
......@@ -131,15 +127,14 @@ debug them later.")
(defmacro recording-breadcrumbs ((pathname record-p) &body body)
`(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
(defmethod operate :before ((operation operation) system &key
(defmethod operate :before ((operation operation) (component t) &key
(breadcrumbs-to nil record-breadcrumbs-p)
((:using-breadcrumbs-from breadcrumb-input-pathname)
(make-broadcast-stream) read-breadcrumbs-p)
(declare (ignorable system))
(recording-breadcrumbs (breadcrumbs-to record-breadcrumbs-p)
(when read-breadcrumbs-p
(perform-plan (read-breadcrumbs-from operation breadcrumb-input-pathname)))))
(setf *default-plan-class* 'parallel-plan)
(setf *plan-class* 'parallel-plan)
......@@ -48,8 +48,8 @@ outputs a tag plus a list of source expressions and their resulting values, retu
;; make-plan make-parallel-plan
;; record-dependency operate make-plan perform-plan perform
;; action-status (setf action-status) action-already-done-p
;; mark-as-done
;; process-return process-result ;; action-result-file
;; input-files output-files file-write-date
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment