-;; -*- Lisp ; coding: utf-8 -*-
+;; -*- mode: Lisp ; coding: utf-8 -*-
;;; This is POIU: Parallel Operator on Independent Units
(cl:in-package :asdf)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *poiu-version* "1.027")
-(defparameter *asdf-version-required-by-poiu* "2.21"))
+(defparameter *poiu-version* "1.28")
+(defparameter *asdf-version-required-by-poiu* "2.26.14"))
#|
POIU is a modification of ASDF that may operate on your systems in parallel.
This version of POIU was designed to work with ASDF no earlier than specified.
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-(declaim (optimize debug safety))
-
+(declaim (optimize (speed 1) (debug 3) (safety 3)))
+;;; check versions
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or clisp clozure sbcl)
(error "POIU doesn't support your Lisp implementation (yet). Help port POIU!")
parallel-load-system parallel-compile-system))
(pushnew :poiu *features*))
-
-;; Some general purpose data structures we use
+;;; Some general purpose data structures we use
(defgeneric table-values (table))
(defmethod table-values ((table hash-table))
(loop :for val :being :the :hash-values :of table :collect val))
(defmacro with-queue ((var qvar &optional (qval '(simple-queue))) &body body)
`(let ((,qvar ,qval)) (call-with-queue (lambda (,var) ,@body) ,qvar)))
-(defun ensure-operation (opoid)
- (etypecase opoid
- (symbol (make-instance opoid))
- (operation opoid)))
-
-(defun ensure-operation-name (opoid)
- (etypecase opoid
- (symbol opoid)
- (operation (type-of opoid))))
-
-(defmacro remove-method-if-defined
- (method-name specializers &optional qualifiers)
- `(when (find-method (function ,method-name) ',qualifiers
- ',specializers
- nil)
- (remove-method (function ,method-name)
- (find-method (function ,method-name)
- ',qualifiers
- ',specializers))))
+;;; Reifying and reconstituting objects for sending across processes
+(defun cl-symbol-p (x)
+ (and (symbolp x) (eq (find-package :cl) (symbol-package x))))
+(deftype cl-symbol () '(and symbol (satisfies cl-symbol-p)))
+(defun reify-symbol (sym)
+ (vector (symbol-name sym) (package-name (symbol-package sym))))
+(defun reconstitute-symbol (sym)
+ (intern (aref sym 0) (aref sym 1)))
+(defun reify-simple-sexp (sexp)
+ (etypecase sexp
+ ((or cl-symbol keyword number character simple-string pathname) sexp)
+ (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
+ (symbol (reify-symbol sexp))))
+(defun reconstitute-simple-sexp (sexp)
+ (etypecase sexp
+ ((or cl-symbol keyword number character simple-string pathname) sexp)
+ (cons (cons (reconstitute-simple-sexp (car sexp)) (reconstitute-simple-sexp (cdr sexp))))
+ ((simple-vector 2) (reconstitute-symbol sexp))))
+
+;;; Extracting undefined-warnings from the compilation-unit
+;;; To be passed through the above reify/reconstitute link, it must be a "simple-sexp"
+(defun undefined-warning-sexp (warning)
+ #-sbcl (declare (ignore warning))
+ #+sbcl
+ (list*
+ (sb-c::undefined-warning-kind warning)
+ (sb-c::undefined-warning-name warning)
+ (sb-c::undefined-warning-count warning)
+ (mapcar
+ #'(lambda (frob)
+ ;; the lexenv slot can be ignored for reporting purposes
+ `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
+ :source ,(sb-c::compiler-error-context-source frob)
+ :original-source ,(sb-c::compiler-error-context-original-source frob)
+ :context ,(sb-c::compiler-error-context-context frob)
+ :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
+ :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
+ :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
+ (sb-c::undefined-warning-warnings warning))))
(defun reconstitute-deferred-warnings (constructor-list)
#-sbcl (declare (ignore constructor-list))
(setf sb-c::*undefined-warnings*
(nconc (mapcan
#'(lambda (stuff)
- (destructuring-bind (kind name count . rest)
- (reconstitute-simple-sexp stuff)
+ (destructuring-bind (kind name count . rest) stuff
(if (and (eq kind :function) (fboundp name))
nil
(list
(otherwise
(set symbol (+ (symbol-value symbol) adjustment)))))))
-(defun cl-symbol-p (x)
- (and (symbolp x) (eq (find-package :cl) (symbol-package x))))
-(deftype cl-symbol () '(and symbol (satisfies cl-symbol-p)))
-(defun reify-symbol (sym)
- (vector (symbol-name sym) (package-name (symbol-package sym))))
-(defun reconstitute-symbol (sym)
- (intern (aref sym 0) (aref sym 1)))
-(defun reify-simple-sexp (sexp)
- (etypecase sexp
- ((or cl-symbol keyword number character simple-string pathname) sexp)
- (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
- (symbol (reify-symbol sexp))))
-(defun reconstitute-simple-sexp (sexp)
- (etypecase sexp
- ((or cl-symbol keyword number character simple-string pathname) sexp)
- (cons (cons (reconstitute-simple-sexp (car sexp)) (reconstitute-simple-sexp (cdr sexp))))
- ((simple-vector 2) (reconstitute-symbol sexp))))
-
-(defun reify-undefined-warnings (warning)
- #+sbcl
- (reify-simple-sexp
- (list* (sb-c::undefined-warning-kind warning)
- (sb-c::undefined-warning-name warning)
- (sb-c::undefined-warning-count warning)
- (mapcar
- #'(lambda (frob)
- ;; the lexenv slot can be ignored for reporting purposes
- `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
- :source ,(sb-c::compiler-error-context-source frob)
- :original-source ,(sb-c::compiler-error-context-original-source frob)
- :context ,(sb-c::compiler-error-context-context frob)
- :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
- :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
- :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
- (sb-c::undefined-warning-warnings warning)))))
-
-(defun get-compilation-unit-report ()
+(defun get-deferred-warnings ()
#-sbcl nil
#+sbcl
(when sb-c::*in-compilation-unit*
;; Try to send nothing through the pipe if nothing needs to be accumulated
`(,@(when sb-c::*undefined-warnings*
- `((sb-c::*undefined-warnings* . ,(mapcar #'reify-undefined-warnings sb-c::*undefined-warnings*))))
+ `((sb-c::*undefined-warnings* . ,(mapcar #'undefined-warning-sexp sb-c::*undefined-warnings*))))
,@(loop for what in '(sb-c::*aborted-compilation-unit-count*
sb-c::*compiler-error-count*
sb-c::*compiler-warning-count*
when (plusp value)
collect `(,what . ,value)))))
+(defun reset-deferred-warnings ()
+ #+sbcl
+ (when sb-c::*in-compilation-unit*
+ (setf sb-c::*undefined-warnings* nil
+ sb-c::*aborted-compilation-unit-count* 0
+ sb-c::*compiler-error-count* 0
+ sb-c::*compiler-warning-count* 0
+ sb-c::*compiler-style-warning-count* 0
+ sb-c::*compiler-note-count* 0)))
+
+;;; Toplevel parallel operations
(defclass parallelizable-operation (operation) ())
-
-(defclass parallel-op (parallelizable-operation)
- ((operations :initarg :operations :accessor parallel-operations)))
-
(defclass parallel-compile-op (compile-op parallelizable-operation) ())
-
(defclass parallel-load-op (load-op parallelizable-operation) ())
-
-(defvar *breadcrumb-stream* (make-broadcast-stream)
- "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")
-
-(defgeneric can-run-in-background-p (operation)
- (:method ((operation symbol))
- (can-run-in-background-p (make-instance operation)))
- (:method ((operation parallelizable-operation))
- nil)
- (:method ((op parallel-compile-op))
- t))
-
-(defgeneric run-in-background-p (operation component &key force)
- (:method ((operation symbol) component &key force)
- (run-in-background-p (make-instance operation) component :force force))
- (:method ((operation parallelizable-operation) component &key force)
- (and (can-run-in-background-p operation)
- (or force
- (not (operation-executed-p operation component))))))
-
-(defgeneric dependee-operations-necessary-p (operation component)
- (:method ((op symbol) component)
- (dependee-operations-necessary-p (make-instance op) component))
- (:method ((op compile-op) component)
- (declare (ignorable op component))
- t)
- (:method ((op operation) component)
- (declare (ignorable op component))
- nil))
-
(defgeneric unparallelize-operation (operation))
(defmethod unparallelize-operation ((op parallel-load-op))
- (load-time-value (make-instance 'load-op)))
+ (make-sub-operation op 'load-op))
(defmethod unparallelize-operation ((op compile-op))
- (load-time-value (make-instance 'compile-op)))
-
-(defmethod operation-done-p ((operation parallelizable-operation) component)
- (operation-done-p (unparallelize-operation operation) component))
-
-(defgeneric operation-executed-p (operation component)
- (:documentation "operation-done-p is at planning time.
-Operation-executed-p is at plan execution time.")
- (:method ((operation symbol) component)
- (operation-executed-p (make-instance operation) component)))
-
-(defun parallelize-action (action)
- (case (car action)
- (compile-op (cons 'parallel-compile-op (cdr action)))
- (load-op (cons 'parallel-load-op (cdr action)))
- (otherwise action)))
-
-;; ASDF somehow maintains a dubious distinction between internal dependencies
-;; that trigger a recompilation and external dependencies that don't.
-;; We don't try to maintain that distinction as we deduce parallel dependencies
-;; from serial dependencies.
-(macrolet ((def-depend-method (class base-class)
- `(defmethod component-depends-on ((operation ,class) c)
- (mapcar #'parallelize-action
- (append
- (cdr (assoc ',base-class (component-do-first c)))
- (call-next-method))))))
- (def-depend-method parallel-compile-op compile-op)
- (def-depend-method parallel-load-op load-op))
-
-(defun component-equal (c1 c2)
- (or (and (null c1) (null c2))
- (and c1 c2 (equal (component-name c1) (component-name c2))
- (component-equal (component-parent c1) (component-parent c2)))))
-
-(defun action-equal (action1 action2)
- (and (eql (car action1) (car action2))
- (component-equal (second action1) (second action2))))
-
-(defun ensure-component (parent coid)
- (etypecase coid
- (component coid)
- ((or symbol string)
- (assert coid)
- (let ((c (find-component parent (coerce-name coid))))
- (unless (typep c 'component)
- (error 'missing-component :requires coid :parent parent))
- c))))
-
-(defun make-dependency-trees (operation module)
- (let ((starting-points (simple-queue))
- ;; component -> dependency map
- (direct-entries (make-hash-table :test #'equal))
- ;; dependency -> component map
- (indirect-entries (make-hash-table :test #'equal)))
- (labels ((add-to-tree (dependency this-operation)
- ;; don't record dependencies from component on itself
- (when (equal dependency this-operation)
- (return-from add-to-tree nil))
- (unless (gethash this-operation direct-entries)
- (setf (gethash this-operation direct-entries)
- (make-hash-table :test #'equal)))
- (unless (gethash dependency indirect-entries)
- (setf (gethash dependency indirect-entries)
- (make-hash-table :test #'equal)))
- (setf (gethash dependency (gethash this-operation direct-entries)) t)
- (setf (gethash this-operation (gethash dependency indirect-entries)) t))
- (is-in-tree-p (dependency)
- (gethash dependency direct-entries))
- (normalize-dependencies (parent deps)
- (let ((queue (simple-queue)))
- (enqueue-normalized-dependencies queue parent deps)
- (dequeue-all queue)))
- (enqueue-normalized-dependencies (queue parent deps)
- (loop :for (op . components) :in deps :do
- (enqueue-normalized-dependencies-entry
- queue parent (ensure-operation-name op) components)))
- (enqueue-normalized-dependencies-entry (queue parent op-name components)
- (loop :for component :in components
- :for comp = (ensure-component parent component) :do
- (etypecase comp
- (module
- (enqueue-normalized-dependencies-entry
- queue comp op-name (module-components comp)))
- (component (enqueue queue (list op-name comp))))))
- (do-components (operation module additional-dependencies)
- (dolist (component (module-components module))
- (do1 operation component additional-dependencies)))
- (do1 (operation component additional-dependencies)
- (let ((operation (ensure-operation-name operation))
- (parent (component-parent component)))
- (when (is-in-tree-p (list operation component))
- (return-from do1))
- (etypecase component
- (module
- (let* ((component-parents
- (loop :for parent = component :then (component-parent parent)
- :while parent :collect parent))
- (deps (loop :for (op . deps) :in (component-depends-on operation component)
- :for real-deps
- = (set-difference (mapcar (lambda (dep) (ensure-component parent dep)) deps)
- component-parents)
- :when real-deps :collect `(,op ,@real-deps))))
- (do-components
- operation component
- (append additional-dependencies (normalize-dependencies parent deps)))
- (loop :for (op comp) :in deps :do
- (do1 op (ensure-component module comp) additional-dependencies))))
- (component
- (let* ((action (list operation component))
- (deps (normalize-dependencies (component-parent component)
- (component-depends-on operation component)))
- (all-deps (append additional-dependencies deps)))
- (unless all-deps
- (enqueue-new starting-points action :test #'equal))
- (loop :for d :in all-deps :do
- (add-to-tree d action))
- (loop :for (op comp) :in deps :do
- (do1 op (ensure-component module comp) additional-dependencies))))))))
- (do-components (ensure-operation-name operation) module nil)
- (values starting-points
- indirect-entries
- direct-entries))))
-
-(defun mark-as-done (operation component indirect-deps direct-deps)
+ (make-sub-operation op 'compile-op))
+
+(defun parallel-load-system (system &rest args)
+ (apply #'operate 'parallel-load-op system args))
+(defun parallel-compile-system (system &rest args)
+ (apply #'operate 'parallel-compile-op system args))
+
+(defgeneric run-in-background-p (operation component)
+ (:method ((o operation) (c component))
+ ;; We presume that actions that modify the filesystem can run in the background,
+ ;; whereas those that don't are meant to side-effect the current image.
+ (and (output-files o c) t)))
+
+(defclass parallel-plan ()
+ ((starting-points :initform (simple-queue))
+ (children :initform (make-hash-table :test #'equal)) ;; map an action to a (hash)set of "children" that it depends on
+ (parents :initform (make-hash-table :test #'equal)) ;; map an action to a (hash)set of "parents" that depend on it
+ (background-actions :initform 0 :accessor plan-background-actions)
+ (ancestor :initarg :ancestor)))
+
+(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) (table-keys children)) :key 'cdr :test-not 'eq))))
+
+(defun record-dependency (parent child parents children)
+ (when parent
+ (unless (gethash parent children)
+ (setf (gethash parent children) (make-hash-table :test #'equal)))
+ (unless (gethash child parents)
+ (setf (gethash child parents) (make-hash-table :test #'equal)))
+ (setf (gethash child (gethash parent children)) t)
+ (setf (gethash parent (gethash child parents)) t)))
+
+(defun mark-as-done (operation component parents children)
;; 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.
- (let* ((operation (ensure-operation-name operation))
- (action (list operation component))
- (dependees (when (gethash action indirect-deps)
- (loop :for dependee :being
- :the :hash-keys :in (gethash action indirect-deps)
- :collect dependee))))
- (remhash action direct-deps)
- (loop :for dependee :in dependees
- :for dependee-deps = (gethash dependee direct-deps)
- :do (assert dependee-deps)
- (remhash action dependee-deps)
- :when (empty-p dependee-deps)
- :collect dependee
- :and :do (remhash dependee direct-deps))))
-
-(defun summarize-direct-deps (dir)
- (sort (loop :for key :being :the :hash-keys :in dir :using (:hash-value val)
- :collect (list key
- (loop :for innerkey :being :the :hash-keys :in val :using (:hash-value v)
- :when v :collect innerkey)))
- #'< :key (lambda (depl) (length (cdr depl)))))
-
-(defun check-dependency-trees (module starting-points indirect-entries direct-entries)
+ (check-type operation operation)
+ (let* ((action (node-for operation component))
+ (action-parents (aif (gethash action parents) (table-keys it))))
+ (remhash action parents)
+ (loop :for parent :in action-parents
+ :for siblings = (gethash parent children)
+ :do (assert siblings)
+ (remhash action siblings)
+ :when (empty-p siblings)
+ :do (remhash parent children)
+ :and :collect parent)))
+
+(defun make-parallel-plan (operation component)
+ (let ((plan (make-instance 'parallel-plan :ancestor operation)))
+ (with-slots (starting-points children parents ancestor background-actions) plan
+ (labels
+ ((visit (o c stamp parent)
+ (let ((action (node-for o c)))
+ (record-dependency parent action parents children)
+ (multiple-value-bind (s p) (component-visited-p o c)
+ (if p
+ (car s)
+ (with-component-being-visited (o c)
+ (visit-action
+ o c
+ #'(lambda (stamp)
+ #'(lambda (o c) (visit o c stamp action)))
+ #'(lambda (o c done-p stamp)
+ (mark-component-visited
+ o c (cons stamp
+ (when (and (not done-p)
+ (run-in-background-p o c))
+ (incf background-actions))))
+ (cond
+ (done-p (mark-operation-done o c)
+ (mark-as-done o c parents children))
+ ((not (gethash action children))
+ (enqueue starting-points (cons o c)))))
+ stamp)))))))
+ (visit operation component nil nil)
+ plan))))
+
+(defun summarize-plan (plan)
+ (with-slots (starting-points children) plan
+ `((:starting-points
+ ,(loop :for (o . c) :in (queue-contents starting-points)
+ :collect (cons (type-of o) (component-find-path c))))
+ (:dependencies
+ ,(flet ((sexpify (action)
+ (destructuring-bind (oname . c) action
+ (cons oname (component-find-path c)))))
+ (sort
+ (loop :for parent :being :the :hash-keys :in children
+ :using (:hash-value progeny)
+ :collect `(,(sexpify parent) :-
+ ,@(loop :for child :being :the :hash-keys :in progeny
+ :using (:hash-value v)
+ :when v :collect (sexpify child))))
+ #'< :key #'length))))))
+
+(defgeneric check-invariants (object))
+
+(defun node-action (node)
+ (destructuring-bind (opname . comp) node
+ (cons (make-instance opname) comp)))
+
+(defmethod check-invariants ((plan parallel-plan))
;; This destructively checks that the dependency tree model is coherent.
- (with-queue (action action-queue starting-points)
- (destructuring-bind (op-name component) action
- (enqueue-many action-queue
- (mark-as-done op-name component
- indirect-entries direct-entries))))
- (unless (empty-p direct-entries)
- (error "Cycle detected in the dependency graph of ~A. Direct dependencies are:~%~S"
- module (summarize-direct-deps direct-entries))))
-
-(defun make-checked-dependency-trees (operation module)
- (multiple-value-call #'check-dependency-trees ;; do it once, destructively check the results
- module (make-dependency-trees operation module))
- (make-dependency-trees operation module)) ;; do it again.
-
-(defparameter *max-forks* 16)
-(defparameter *max-actual-forks* 0)
-
-;;; subprocesses: data structure, ipc
-
-(defvar *current-subprocess*)
+ (with-slots (starting-points parents children ancestor) plan
+ (with-queue (action action-queue starting-points)
+ (destructuring-bind (operation . component) action
+ (enqueue-many action-queue
+ (mapcar 'node-action (mark-as-done operation component parents children)))))
+ (unless (empty-p children)
+ (error "Cycle detected in the dependency graph:~%~S"
+ (summarize-plan plan))))
+ t)
-(defparameter *default-process-result*
- '())
-(defparameter *failed-process-result*
- '(:failure-p t :performed-p t))
+(defun make-checked-parallel-plan (operation module)
+ (check-invariants (make-parallel-plan operation module)) ;; do it once, destructively check the results
+ (make-parallel-plan operation module)) ;; do it again.
-(defclass communicating-subprocess ()
- ((pid :initarg :pid :accessor process-pid)
- (data :initarg :data :accessor process-data)
- (cleanup-thunk :initarg :cleanup :accessor process-cleanup)
- (status-pipe :accessor status-pipe)))
+(defmethod traverse ((operation parallelizable-operation) system)
+ (make-parallel-plan (unparallelize-operation operation) system))
-#|
-(defclass communicating-thread ()
- ((thread :initarg :thread :accessor process-thread)
- (data :initarg :data :accessor process-data)
- (cleanup-thunk :initarg :cleanup :accessor process-cleanup)
- (lock :initform (ccl:make-lock) :accessor process-lock)
- (status :initform () :accessor process-status)))
-|#
-
-(defun process-result (exit-status result-pipe)
- (prog1
- (or (and (member exit-status '(0 nil))
- (ignore-errors (read result-pipe)))
- *failed-process-result*)
- (close result-pipe)))
+(defparameter *max-forks* 16)
+(defparameter *max-actual-forks* nil)
-(defun process-return (proc result)
- (prin1 result (status-pipe proc)))
+;;; subprocesses: abstraction for the implementation-dependent low-level API
(defun finish-outputs ()
+ ;; This is notably necessary for CCL, that buffers output
(finish-output *standard-output*)
(finish-output *error-output*)
(values))
+(defun disable-other-waiters ()
+ ;; KLUDGE: Try to undo problems caused by run-program.
+ ;; There will still be a race condition if some action calls run-program at load-time.
+ ;; But this work-around makes it is safe to call run-program before to invoke poiu
+ ;; (it is of course safe after). The true fix to allow run-program to be invoked
+ ;; at load-time would be to have an API for a process-waiting callbacks.
+ #+sbcl
+ (sb-sys:default-interrupt sb-unix:sigchld)) ; ignore-interrupt is undefined for SIGCHLD.
+
+
#+sbcl
(progn
(defun make-input-stream (fd)
(sb-sys:make-fd-stream fd :input t))
-) ;#+sbcl
-
+);#+sbcl
#+clozure
(progn
(defun make-input-stream (fd)
(ccl::make-fd-stream fd :direction :input))
-) ;#+clozure
+);#+clozure
#+clisp ;;; CLISP specific fork support
(progn
);#+clisp
-(defun make-communicating-subprocess (data continuation cleanup)
- (multiple-value-bind (read-fd write-fd) (posix-pipe)
- ;; Try to undo problems caused by sb-ext:run-program. XXX: hack.
- ;; Will still cause a race condition if an ASDF op calls run-program at load-time.
- ;; But this work-around makes it is safe to call run-program before to invoke poiu
- ;; (it is of course safe after). The true fix to allow run-program to be invoked
- ;; at load-time would be to define and hook into an exported interface for process interaction.
- #+sbcl
- (sb-sys:default-interrupt sb-unix:sigchld) ; ignore-interrupt is undefined for SIGCHLD.
- (finish-outputs)
- (let* ((pid (posix-fork))
- (proc (make-instance 'communicating-subprocess
- :pid pid
- :cleanup cleanup
- :data data)))
- (cond ((zerop pid)
- ;; don't receive the parent's SIGINTs
- (posix-setpgrp)
- ;; close the read end, set the write end to be the status reporter.
- (posix-close read-fd)
- (setf (status-pipe proc) (make-output-stream write-fd))
- (when (find-package :sb-sprof)
- (funcall (intern "STOP-PROFILING" :sb-sprof)))
- (let ((*current-subprocess* proc))
- #+sbcl
- (progn
- (sb-ext:disable-debugger)
- ;; If POIU performs some part of a plan serially by compiling in the parent Lisp,
- ;; its warnings should not propagate to children.
- ;; In fact, the child's warning counters should probably be reset too,
- ;; but the more visible brain-damage was the warning list.
- (setf sb-c::*undefined-warnings* nil))
- #+clozure (setf ccl::*batch-flag* t)
- (unwind-protect (funcall continuation data)
- (close (status-pipe proc))
- (finish-outputs)
- (posix-exit 0))))
- (t
- ;; close the write end, set up the read end
- (posix-close write-fd)
- (setf (status-pipe proc) (make-input-stream read-fd))
- proc)))))
+;;; Timing the build process
+
+(defvar *time-spent-waiting* 0)
+
+(defmacro timed-do ((time-accumulator) &body body)
+ (let ((time-before-thing (gensym)))
+ `(let ((,time-before-thing (get-internal-real-time)))
+ (multiple-value-prog1 (progn ,@body)
+ (incf ,time-accumulator (- (get-internal-real-time)
+ ,time-before-thing))))))
+
+;;; Handling multiple processes: high-level API
+
+(defclass background-process ()
+ ((pid :initarg :pid :accessor process-pid)
+ (data :initarg :data :accessor process-data)
+ (cleanup :initarg :cleanup :accessor process-cleanup)
+ ;; We pass results through a file: pipes may cause deadlocks due to full buffers and naive event loop.
+ (result-file :initarg :result-file :accessor process-result-file)))
+
+(define-condition process-failed (error)
+ ((exit-status :initarg :exit-status)
+ (condition :initform nil :initarg :condition)))
+
+(defun process-return (result-file result condition)
+ (with-open-file (s result-file
+ :direction :output :if-exists :rename-and-delete :if-does-not-exist :create)
+ (with-standard-io-syntax
+ (let ((*package* (find-package :cl))
+ (*read-eval* nil)
+ (*print-readably* nil))
+ (write (reify-simple-sexp
+ `(:process-done
+ ,@(when result `(:result ,result))
+ ,@(when condition `(:condition ,(princ-to-string condition)))))
+ :stream s)))))
+
+(defun process-result (process status)
+ (block nil
+ (when status
+ (let ((exit-status (posix-wexitstatus status)))
+ (unless (zerop exit-status)
+ (return (values nil (make-condition 'process-failed :exit-status exit-status))))))
+ (multiple-value-bind (form condition)
+ (ignore-errors
+ (with-open-file (s (process-result-file process)
+ :direction :input :if-does-not-exist :error)
+ (with-standard-io-syntax
+ (let ((*package* (find-package :cl))
+ (*read-eval* nil)
+ (*print-readably* nil))
+ (read s)))))
+ (when condition
+ (return (values nil (make-condition 'process-failed :condition "Could not read result file"))))
+ (unless (and (consp form) (eq (car form) :process-done))
+ (return (values nil (make-condition 'process-failed :condition "Invalid result file"))))
+ (destructuring-bind (&key result condition) (cdr form)
+ (return (values result (when condition (make-condition 'process-failed :condition condition))))))))
+
+(defun make-background-process (data function cleanup result-file)
+ (disable-other-waiters)
+ (finish-outputs)
+ (let ((pid (posix-fork)))
+ (cond
+ ((zerop pid) ; in the child
+ ;; don't receive the parent's SIGINTs
+ (posix-setpgrp)
+ #+sbcl
+ (progn
+ (sb-ext:disable-debugger)
+ (when (find-package :sb-sprof)
+ (funcall (intern "STOP-PROFILING" :sb-sprof))))
+ #+clozure (setf ccl::*batch-flag* t)
+ (reset-deferred-warnings)
+ (multiple-value-bind (result condition)
+ (ignore-errors (values (funcall function data t)))
+ (process-return result-file result condition)
+ (finish-outputs)
+ (posix-exit 0)))
+ (t ; in the parent
+ (make-instance 'background-process
+ :pid pid
+ :result-file result-file
+ :cleanup cleanup
+ :data data)))))
+
+(defun call-queue/forking (fun queue
+ &key announce cleanup result-file (background-p (constantly t)))
+ ;; assumes a single-threaded parent process
+ (declare (optimize debug))
+ (loop :with processes = (make-hash-table :test 'equal) :do
+ (cond
+ (;; nothing to do or wait for anymore.
+ (and (empty-p queue) (empty-p processes))
+ (return))
+ (;; we've exceeded the subprocess limit. Wait for a few before continuing.
+ (or (>= (hash-table-count processes) *max-forks*)
+ (empty-p queue))
+ (disable-other-waiters)
+ (multiple-value-bind (pid status)
+ (timed-do (*time-spent-waiting*) (posix-wait))
+ (flet ((cleanup (process status)
+ (multiple-value-bind (result condition)
+ (process-result process status)
+ (funcall (process-cleanup process) (process-data process) result condition t))))
+ (if pid
+ (let ((process (gethash pid processes)))
+ (assert process () "couln't find the pid ~A in processes ~S" pid (table-values processes))
+ (remhash pid processes)
+ (cleanup process status))
+ ;; clisp can currently drop signals and get a ENOCHILD...
+ (let ((missed (table-values processes)))
+ (warn "No child left: we must have dropped a signal!")
+ ;;;(warn "blah ~S" entries) ;XXX
+ (clrhash processes)
+ (dolist (process missed)
+ (cleanup process nil)))))))
+ (t ;; dequeue an item
+ (let* ((item (dequeue queue))
+ (backgroundp (funcall background-p item)))
+ (funcall announce item backgroundp)
+ (cond
+ (backgroundp
+ (latest-stamp-f *max-actual-forks* (hash-table-count processes))
+ (let ((process (make-background-process item fun cleanup (funcall result-file item))))
+ (setf (gethash (process-pid process) processes) process)))
+ (t
+ (multiple-value-bind (result condition)
+ (ignore-errors (values (funcall fun item nil)))
+ (funcall cleanup item result condition nil))))))
+ :finally
+ (assert (and (empty-p queue) (empty-p processes)) ()
+ "List of processes or list of things to do isn't empty: ~S / ~S~%"
+ (queue-contents queue)
+ (table-values processes)))))
+
+(defmacro doqueue/forking ((queue &key variables
+ (background-p t) (announce nil) (cleanup nil) result-file)
+ &body body)
+ (destructuring-bind (&key item (backgroundp (gensym "BACKGROUNDP")) result condition) variables
+ `(call-queue/forking
+ #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,@body)
+ ,queue
+ :result-file #'(lambda (,item) (declare (ignorable ,item)) ,result-file)
+ :background-p #'(lambda (,item) (declare (ignorable ,item)) ,background-p)
+ :announce #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,announce)
+ :cleanup #'(lambda (,item ,result ,condition ,backgroundp)
+ (declare (ignorable ,item ,result ,condition ,backgroundp)) ,cleanup))))
+
+#|
+;;; Vague attempt at doing things with threads.
+;;; BUT, compilation takes a global lock in CCL, so it's no go.
+
+(defclass communicating-thread ()
+ ((thread :initarg :thread :accessor process-thread)
+ (data :initarg :data :accessor process-data)
+ (cleanup :initarg :cleanup :accessor process-cleanup)
+ (lock :initform (ccl:make-lock) :accessor process-lock)
+ (status :initform () :accessor process-status)))
#+clozure
(defparameter *null-stream*
(open "/dev/null" :direction :io :if-does-not-exist :error :if-exists :append))
-#|
#+clozure
(defun make-communicating-thread (semaphore data continuation cleanup)
(let* ((proc (make-instance 'communicating-thread
"worker"
(lambda ()
(handler-case
- (let ((*current-subprocess* proc)
- (*standard-input* *null-stream*))
+ (let ((*standard-input* *null-stream*))
(catch :process-return
(funcall continuation data)))
(t (c)
#+clozure
(defun thread-result (proc)
(second (process-status proc)))
-|#
-
-;;; Timing the build process
-
-(defvar *time-spent-waiting* 0)
-
-(defmacro timed-do ((time-accumulator) &body body)
- (let ((time-before-thing (gensym)))
- `(let ((,time-before-thing (get-internal-real-time)))
- (multiple-value-prog1 (progn ,@body)
- (incf ,time-accumulator (- (get-internal-real-time)
- ,time-before-thing))))))
-
-;;; Handling multiple processes
-
-(defun call-queue/forking (thunk queue
- &key announce cleanup (background-p (constantly t)))
- ;; assumes a single-threaded parent process
- (declare (optimize debug))
- (let ((elem nil)
- (processes (make-hash-table :test 'equal)))
- (loop
- ;;;(warn "cqf~% count: ~S~% elem: ~S~% map: ~S" (hash-table-count processes) elem (table-values processes))
- (cond (;; nothing to do or wait for anymore.
- (and (empty-p queue) (empty-p processes))
- (return))
- (;; we've exceeded the subprocess limit. Wait for a few before continuing.
- (or (>= (hash-table-count processes) *max-forks*)
- (empty-p queue))
- (multiple-value-bind (pid status)
- (timed-do (*time-spent-waiting*) (posix-wait))
- (flet ((cleanup (entry exit-status)
- (funcall (process-cleanup entry) (process-data entry)
- (process-result exit-status (status-pipe entry)))))
- (if pid
- (let ((entry (gethash pid processes)))
- (assert entry () "couln't find the pid ~A in processes ~S" pid (table-values processes))
- (remhash pid processes)
- (cleanup entry (posix-wexitstatus status)))
- ;; clisp can currently drop signals and get a ENOCHILD...
- (let ((entries (table-values processes)))
- (warn "No child left: we must have dropped a signal!")
- ;;;(warn "blah ~S" entries) ;XXX
- (clrhash processes)
- (dolist (entry entries)
- (cleanup entry nil))))))))
- (unless (empty-p queue)
- (setf elem (dequeue queue))
- (funcall announce elem)
- (cond
- ((funcall background-p elem)
- (when (> (hash-table-count processes) *max-actual-forks*)
- (setf *max-actual-forks* (hash-table-count processes)))
- (let ((process (make-communicating-subprocess elem thunk cleanup)))
- (setf (gethash (process-pid process) processes) process)))
- (t
- (unwind-protect (funcall thunk elem)
- (funcall cleanup elem *default-process-result*))))))
- (assert (and (empty-p queue) (empty-p processes)) ()
- "List of processes or list of things to do isn't empty: ~S / ~S~%"
- (queue-contents queue)
- (table-values processes)))
- nil)
-#|
#+clozure
(defun call-queue/threading (thunk queue &key cleanup (background-p (constantly t)))
;; will use threads instead of fork
(setf elem (dequeue queue))
(cond
((funcall background-p elem)
- (when (> (hash-table-count processes) *max-actual-forks*)
- (setf *max-actual-forks* (hash-table-count processes)))
+ (latest-stamp-f *max-actual-forks* (hash-table-count processes))
(let ((thread (make-communicating-thread pending elem thunk cleanup)))
(setf (gethash thread processes) thread)))
(t
nil)
|#
-(defmacro doqueue/forking ((var queue
- &key
- (result (gensym "RESULT"))
- (background-p t) (announce nil) (cleanup nil))
- &body body)
- `(call-queue/forking
- #'(lambda (,var) (declare (ignorable ,var)) ,@body)
- ,queue
- :cleanup #'(lambda (,var ,result) (declare (ignorable ,var ,result)) ,cleanup)
- :announce #'(lambda (,var) (declare (ignorable ,var)) ,announce)
- :background-p #'(lambda (,var) (declare (ignorable ,var)) ,background-p)))
-
-(defmethod perform :after ((operation parallel-compile-op) c)
- (mark-operation-done (make-instance 'compile-op) c))
-
-(defmethod perform :after ((operation parallel-load-op) c)
- (mark-operation-done (make-instance 'load-op) c))
-
-(defmethod perform :after ((operation operation) c)
- "Record the operations and components in a stream of breadcrumbs."
- (labels ((component-module-path (c)
- (unless (typep c 'system)
- (cons (coerce-name (component-name c))
- (component-module-path (component-parent c))))))
- (format *breadcrumb-stream* "~S~%"
- `(,(type-of operation)
- ,(coerce-name (component-name (component-system c)))
- ,@(component-module-path c)))
- (force-output *breadcrumb-stream*)))
-
-(defun file-compile-action-p (action)
- (destructuring-bind (op comp &optional necessary-p) action
- (declare (ignore necessary-p))
- (and (typep (ensure-operation op) 'parallel-compile-op) (typep comp 'source-file))))
-
-(defmethod perform-with-restarts ((operation parallelizable-operation) (module module))
- (multiple-value-bind (action-queue ind dir) (make-checked-dependency-trees operation module)
- (unless (empty-p action-queue)
- (let ((all-compilation-unit-reports nil)
- (system-name (coerce-name (component-system module)))
- (n (length (remove-if-not 'file-compile-action-p (table-keys dir)))))
+;;; 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))))
+
+(defmethod perform-plan ((plan parallel-plan) &key)
+ (with-slots ((action-queue starting-points) children parents ancestor background-actions) plan
+ (DBG :pp (summarize-plan plan))
+ (let ((all-compilation-unit-reports nil)
+ (ltogo (unless (zerop background-actions) (ceiling (log background-actions 10))))
+ (*package* *package*)
+ (*readtable* *readtable*))
+ (with-compilation-unit ()
(doqueue/forking
- (action action-queue
- :result result
- :background-p
- (destructuring-bind (op comp &optional necessary-p) action
- (run-in-background-p op comp :force necessary-p))
+ (action-queue ;; variable for each action, queue object
+ :variables (:item action :backgroundp backgroundp :result result :condition condition)
+ :background-p (destructuring-bind (o . c) action (run-in-background-p o c))
+ :announce
+ (format t "~&Will try ~A in ~:[foreground~;background~]~%"
+ (destructuring-bind (o . c) action (operation-description o c)) backgroundp)
+ :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 (&key input-file compilation-unit-report
- failure-p performed-p &allow-other-keys)
- result
- (when input-file
- (format t "~&~@[[~4d to go in ~A] ~]Done compiling ~A~%"
- ;; Don't show negatives. (It's good enough for me)
- ;; I really don't care that or why I'm counting wrong.
- n system-name input-file)
+ (destructuring-bind (o . c) action
+ (cond
+ (condition
+ (finish-outputs)
+ (warn "Failed ~A~:[~; in the background~]. Retrying~:*~:[~; in the foreground~]."
+ (operation-description o c) backgroundp)
+ (finish-outputs)
+ (perform-with-restarts o c))
+ (t
+ (mark-operation-done o c)
+ (destructuring-bind (&key compilation-unit-report &allow-other-keys) result
+ (when compilation-unit-report
+ (push compilation-unit-report all-compilation-unit-reports)))))
+ (when backgroundp
+ (decf background-actions)
+ (format t "~&[~vd to go] Done ~A~%"
+ ltogo background-actions (operation-description o c))
(finish-outputs))
- (when (file-compile-action-p action)
- (decf n))
- (when compilation-unit-report
- (push compilation-unit-report all-compilation-unit-reports))
- (destructuring-bind (operation component &optional necessary-p) action
- (when failure-p
- (finish-outputs)
- (warn "Action ~A has failure-p set. Retrying in this process." action)
- (finish-outputs)
- (perform-with-restarts (ensure-operation operation) component))
- (loop :for (opened-op opened-comp) :in (mark-as-done operation component ind dir)
- :for opened-necessary-p
- = (or necessary-p
- (and performed-p
- (dependee-operations-necessary-p operation component)))
- :for opened-action = (list opened-op opened-comp opened-necessary-p)
- :do (if (can-run-in-background-p opened-op)
- (enqueue-in-front action-queue opened-action)
- (enqueue action-queue opened-action))))))
- (destructuring-bind (operation component &optional necessary-p) action
- (when (or necessary-p
- (not (operation-executed-p operation component)))
- (perform-with-restarts (ensure-operation operation) component))))
- (mapc #'reconstitute-deferred-warnings all-compilation-unit-reports)))
- (assert (empty-p dir)
- (dir ind)
- "Direct dependency table is not empty - there is a problem ~
- with the dependency trees:~%~S" (summarize-direct-deps dir))))
-
-(defmethod perform :before ((operation parallel-compile-op) (c source-file))
- (ensure-all-directories-exist (asdf:output-files operation c)))
-
-(defmethod perform ((op parallel-compile-op) (c cl-source-file))
- (let* ((source-file (component-pathname c))
- ;; on some implementations, there are more than one output-file,
- ;; but the first one should always be the primary fasl that gets loaded.
- (output-file (first (output-files op c)))
- (compile-status (list
- :input-file source-file
- :performed-p t
- :output-truename output-file
- :warnings-p nil
- :failure-p t))
- warnings-p failure-p output-truename)
- (unwind-protect (progn
- (multiple-value-setq (output-truename warnings-p failure-p)
- (call-with-around-compile-hook
- c #'(lambda (&rest flags)
- (apply *compile-op-compile-file-function* source-file
- :output-file output-file
- :external-format (component-external-format c)
- (append flags (compile-op-flags op))))))
- (setf compile-status
- (list :input-file source-file
- :performed-p t
- :output-truename output-truename
- :compilation-unit-report (get-compilation-unit-report)
- :warnings-p warnings-p
- :failure-p failure-p)))
- (finish-outputs)
- (cond
- ((boundp '*current-subprocess*)
- (process-return *current-subprocess* compile-status))
- (t
- (when warnings-p
- (ecase (operation-on-warnings op)
- (:warn (warn
- "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
- op c))
- (:error (error 'compile-warned :component c :operation op))
- (:ignore nil)))
- (when failure-p
- (ecase (operation-on-failure op)
- (:warn (warn
- "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
- op c))
- (:error (error 'compile-failed :component c :operation op))
- (:ignore nil)))
- (unless output-truename
- (error 'compile-error :component c :operation op)))))))
-
-(defmethod perform-with-restart :around ((operation parallelizable-operation) c)
- (unless (operation-executed-p operation c)
- (call-next-method)))
+ (loop :for enabled-node :in (mark-as-done o c parents children)
+ :for (e-o . e-c) = enabled-node
+ :for ee-o = (make-sub-operation o e-o)
+ :for enabled-action = (cons ee-o e-c)
+ :do (if (run-in-background-p ee-o e-c)
+ (enqueue-in-front action-queue enabled-action)
+ (enqueue action-queue enabled-action)))))
+ ;; What we do in each forked process
+ (destructuring-bind (o . c) action
+ (perform o c)
+ (when backgroundp `(:deferred-warnings ,(get-deferred-warnings)))))
+ (mapc #'reconstitute-deferred-warnings all-compilation-unit-reports)
+ (assert (and (empty-p action-queue) (empty-p children))
+ (parents children)
+ "Problem with the dependency graph: ~S"
+ (summarize-plan plan))))))
+
+;;; Breadcrumbs: feature to replay otherwise non-deterministic builds
+(defvar *breadcrumb-stream* (make-broadcast-stream)
+ "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")
-(defmethod operation-executed-p ((op parallelizable-operation) (c module))
- "A lazy operation on a module is done only when the op on all its
-components is done."
- (labels ((dependency-done-p (op sub-c)
- (loop :for (dep-op-name . dep-component-names)
- :in (component-depends-on op sub-c)
- :for dep-op = (make-instance dep-op-name)
- :do (loop :for dep-component-name :in dep-component-names
- :for dep-c = (ensure-component (component-parent sub-c)
- dep-component-name)
- :do (unless (operation-executed-p dep-op dep-c)
- (return-from dependency-done-p nil))))
- t))
- (every (lambda (sub-c)
- (and (dependency-done-p op sub-c)
- (operation-executed-p op sub-c)))
- (module-components c))))
-
-(defmethod operation-executed-p ((operation parallel-load-op) (c static-file))
- t)
-(defmethod operation-executed-p ((operation parallel-compile-op) (c static-file))
- t)
-(defmethod operation-executed-p ((operation compile-op) c)
- (operation-done-p operation c))
-(defmethod operation-executed-p ((operation load-op) c)
- (operation-done-p operation c))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; invoking operations
-
-(defun read-breadcrumbs-from (pathname)
- (labels ((resolve-component-path (component path)
- (if (null path)
- component
- (resolve-component-path (ensure-component component (first path))
- (rest path)))))
- (with-open-file (f pathname)
- (loop :for (op-name system-name . component-path) = (read f nil nil)
- :until (null op-name)
- :collect (cons (make-instance op-name)
- (resolve-component-path (find-system system-name)
- component-path))))))
+(defmethod perform :after ((o operation) (c component))
+ "Record the operations and components in a stream of breadcrumbs."
+ (format *breadcrumb-stream* "~S~%" `(,(type-of o) . ,(component-find-path c)))
+ (force-output *breadcrumb-stream*))
+
+(defun read-breadcrumbs-from (operation pathname)
+ (with-open-file (f pathname)
+ (loop :for (op . comp) = (read f nil nil) :while op
+ :collect (cons (make-sub-operation operation op) (find-component () comp)))))
(defun call-recording-breadcrumbs (pathname record-p thunk)
(if record-p
- (with-open-file (*breadcrumb-stream*
- pathname :direction :output
- :if-exists :supersede :if-does-not-exist :create)
- (funcall thunk))
+ (let ((*breadcrumb-stream*
+ (open pathname :direction :output
+ :if-exists :rename-and-delete :if-does-not-exist :create)))
+ (format *breadcrumb-stream* ";; Breadcrumbs~%")
+ (unwind-protect
+ (funcall thunk)
+ (close *breadcrumb-stream*)))
(funcall thunk)))
+
(defmacro recording-breadcrumbs ((pathname record-p) &body body)
`(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
-(defmethod traverse :around ((operation parallelizable-operation) system)
- (append *breadcrumbs*
- (remove 'system (call-next-method) :test-not #'eq
- :key (lambda (x) (type-of (cdr x))))))
-
-(defmethod operate :around ((operation-class parallelizable-operation) system &key
+(defmethod operate :around (operation system &key
(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)
- (let ((*breadcrumbs* (when read-breadcrumbs-p
- (read-breadcrumbs-from breadcrumb-input-pathname))))
- (call-next-method))))
-
-(defun parallel-load-system (system &rest args)
- (apply #'operate 'parallel-load-op system args))
-
-(defun parallel-compile-system (system &rest args)
- (apply #'operate 'parallel-compile-op system args))
+ (when read-breadcrumbs-p
+ (perform-plan (read-breadcrumbs-from operation breadcrumb-input-pathname)))
+ (call-next-method)))
common-lisp.net / projects/qitab/poiu.git / commitdiff
