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

1.31: split into many files

parent e1ff48ef
Loading
Loading
Loading
Loading

COPYING

0 → 100644
+21 −0
Original line number Diff line number Diff line
ASDF (and hence POIU that is derived from it) is
Copyright (c) 2001-2003 Daniel Barlow and contributors

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+66 −0
Original line number Diff line number Diff line
@@ -4,6 +4,72 @@ POIU: Parallel Operator on Independent Units
POIU is an ASDF extension that will parallelize your Common Lisp builds,
for some build speedup, both through parallelization and reduced GC.


Introduction
------------

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.

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.

POIU will only make a difference with respect to ASDF if the dependencies
are not serial (i.e. no difference for systems using `:serial t` everywhere).
You can however use Andreas Fuchs's `ASDF-DEPENDENCY-GROVEL` to autodetect
minimal dependencies from an ASDF system (or a set of multiple such).

POIU may speed up compilation by utilizing all CPUs of an SMP machine.
POIU may also reduce the memory pressure on the main (loading) process.
POIU will enforce separation between compile- and load- time environments,
helping you detect when `:LOAD-TOPLEVEL` is missing in `EVAL-WHEN`'s
as needed for incremental compilation even with vanilla ASDF.
POIU will also catch *some* missing dependencies as exist between the
files that it will happen to compile in parallel (but may not catch all
dependencies that may otherwise be missing from your system).

When a compilation fails in a parallel process, POIU will retry compiling
in the main (loading) process so you get the usual ASDF error behavior,
with a chance to debug the issue and restart the operation.

POIU was currently only made to work with SBCL, CCL and CLISP.
Porting to another Lisp implementation that supports ASDF
should not be difficult. [Note: the CLISP port is somewhat less stable.]
When unable to fork because the implementation is unsupported,
or because multiple threads are currently in use,
POIU will fall back to compiling everything in the main process.

Warning to CCL users: you need to save a CCL image that doesn't start threads
at startup in order to use POIU (or anything that uses fork).
Watch [QITAB](https://common-lisp.net/project/qitab/)
for a package that does just that: `SINGLE-THREADED-CCL`.

To use POIU, (1) make sure `asdf.lisp` is loaded.
We require a recent enough ASDF 3; see specific requirement in [poiu.asd](poiu.asd).
Usually, you can just:
	(require "asdf")

(2) configure ASDF's `SOURCE-REGISTRY` or its `*CENTRAL-REGISTRY*`,
then load POIU:
	(asdf:load-system :poiu)

(3) POIU is active by default. You can just
	(asdf:load-system :your-system)

and POIU will be used to compile it.
Once again, you may want to first use `asdf-dependency-grovel`
to minimize the dependencies in your system.

POIU was initially written by Andreas Fuchs in 2007
as part of an experiment funded by ITA Software, Inc.
It was subsequently modified by Francois-Rene Rideau at ITA Software,
who adapted POIU for use with XCVB in 2009,
wrote the CCL and CLISP ports, moved code from POIU to ASDF, and
eventually rewrote both of them together in a simpler way.
The original copyright and (MIT-style) licence of ASDF (below) applies to POIU.


Usage
-----

action-graph.lisp

0 → 100644
+186 −0
Original line number Diff line number Diff line
(uiop:define-package :poiu/action-graph
  (:use :uiop/common-lisp :uiop :poiu/queue
        :asdf/upgrade
        :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
           #:reify-action #:mark-as-done #:plan-deterministic-p))
(in-package :poiu/action-graph)

(defvar *parallel-plan-deterministic-p* t) ;; Use the deterministic build by default.

(defclass parallel-plan (plan-traversal)
  ((starting-points
    :initform (simple-queue) :reader plan-starting-points
    :documentation "a queue of actions with no dependencies")
   (children
    :initform (make-hash-table :test #'equal) :reader plan-children
    :documentation "map an action to a (hash)set of \"children\" that it depends on")
   (parents
    :initform (make-hash-table :test #'equal) :reader plan-parents
    :documentation "map an action to a (hash)set of \"parents\" that depend on it")
   (all-actions
    :initform (make-array '(0) :adjustable t :fill-pointer 0) :reader plan-all-actions)
   (deterministic-p
    :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?")))

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

(defun make-action-map ()
  (make-hash-table :test 'equal))
(defun action-map (map action)
  (gethash (action-node action) map))
(defun action-unmap (map action)
  (remhash (action-node action) map))
(defun (setf action-map) (value map action)
  (setf (gethash (action-node action) map) value))
(defun action-map-values (map)
  (table-values map))
(defun action-map-keys (map)
  (mapcar 'node-action (table-keys map)))

(defun record-dependency (parent child parents children)
  (unless (action-map parents child)
    (setf (action-map parents child) (make-action-map)))
  (when parent
    (unless (action-map children parent)
      (setf (action-map children parent) (make-action-map)))
    (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)
  ;; 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))
                             (action-map-keys it)))
           (action-children (if-let (it (action-map children action))
                              (action-map-keys it))))
      (action-unmap parents action)
      (action-unmap children action)
      (let ((enabled-parents
              (loop :for parent :in action-parents
                    :for siblings = (action-map children parent)
                    :do (assert siblings)
                        (action-unmap siblings action)
                    :when (empty-p siblings)
                      :do (action-unmap children parent)
                      :and :collect parent))
            (forlorn-children
              (loop :for child :in action-children
                    :for spouses = (action-map parents child)
                    :do (assert spouses)
                        (action-unmap spouses action)
                    :when (empty-p spouses)
                      :do (action-unmap parents child)
                      :and :collect child)))
        (loop :for enabled-action :in enabled-parents
            :for (e-o . e-c) = enabled-action
            :do (if (and (needed-in-image-p e-o e-c) (not (action-already-done-p plan e-o e-c)))
                    (enqueue starting-points enabled-action)
                    (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 (setf plan-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)))
      (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
    `((:starting-points
       ,(loop :for action :in (queue-contents starting-points)
              :collect (reify-action action)))
      (:dependencies
       ,(mapcar #'rest
                  (sort
                   (loop :for parent-node :being :the :hash-keys :in children
                         :using (:hash-value progeny)
                         :for parent = (node-action parent-node)
                         :for (o . c) = parent
                         :collect `(,(action-index (plan-action-status plan o c))
                                    ,(reify-action 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))))
                   #'< :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))
          :for (o . c) = action
          :for status = (plan-action-status plan o c)
          :when (action-planned-p status) :collect action)))

(defgeneric check-invariants (object))

(defmethod check-invariants ((plan parallel-plan))
  ;; This destructively checks that the dependency tree model is coherent.
  (while-collecting (collect)
    (with-slots (starting-points parents children) plan
      (with-queue (action action-queue starting-points)
        (collect action)
        (destructuring-bind (operation . component) action
          (mark-as-done plan operation component)))
      (unless (empty-p children)
        (error "Cycle detected in the dependency graph:~%~S"
               plan)))))

(defmethod make-plan :around (plan-class (o operation) (c component) &key &allow-other-keys)
  (let ((plan (call-next-method)))
    (when (typep plan 'parallel-plan)
      ;; make a plan once already and destructively check it
      (check-invariants (call-next-method)))
    plan))

(defmethod plan-actions ((plan parallel-plan))
  (coerce (plan-all-actions plan) 'list))
+180 −0
Original line number Diff line number Diff line
(uiop:define-package :poiu/background-process
  (:use :uiop/common-lisp
        :uiop/utility :uiop/stream
        :uiop/lisp-build :uiop/image
        :poiu/queue :poiu/fork)
  (:export #:doqueue/forking))
(in-package :poiu/background-process)

;;; 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 :supersede :if-does-not-exist :create)
    (with-safe-io-syntax ()
      (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-safe-io-syntax ()
             (unreify-simple-sexp (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)
       (unwind-protect
            (multiple-value-bind (result condition)
                (ignore-errors (values (funcall function data t)))
              (process-return result-file result condition))
         (finish-outputs)
         (quit 0 t)))
      (t ; in the parent
       (make-instance 'background-process
                      :pid pid
                      :result-file result-file
                      :cleanup cleanup
                      :data data)))))

(defun call-queue/forking (fun fg-queue bg-queue
			   &key announce cleanup result-file deterministic-order)
  ;; assumes a single-threaded parent process
  (declare (optimize debug))
  (let ((processes (make-hash-table :test 'equal)))
    (labels
        ((fg-perform (action)
           (funcall announce action nil)
           (multiple-value-bind (result condition)
               (ignore-errors (values (funcall fun action nil)))
             (funcall cleanup action result condition nil)))
         (cleanup-one (process status)
           (multiple-value-bind (result condition)
               (process-result process status)
             (funcall (process-cleanup process)
                      (process-data process) result condition t)))
         (reap (&key wait)
           (disable-other-waiters)
           (multiple-value-bind (pid status)
               (timed-do (*time-spent-waiting*) (posix-waitpid -1 :nohang (not wait)))
             (etypecase pid
               ((eql 0) ;; no process ended and nohang? Just return NIL.
                nil)
               ((integer 1 *) ;; some process ended? reap it!
                (let ((process (gethash pid processes)))
                  (assert process () "couln't find the pid ~A in processes ~S" pid (table-values processes))
                  (remhash pid processes)
                  (cleanup-one process status))
                t)
               ((eql -1) ;; error?
                (assert (eql status +echild+) (status))
                ;; we were waiting for some process(es),
                ;; but the OS says everything was already reaped?
                ;; Our implementation or some library may have disabled the SIGCHLD signal
                ;; or preempted our wait. Mark all processes as completed.
                (let ((missed (table-values processes)))
                  (warn "No child left: we must have dropped a signal!")
                  (clrhash processes)
                  (dolist (process missed)
                    (cleanup-one process nil)))
                t)))))
      (loop
        (let* ((no-fg-item? (empty-p fg-queue))
               (fg-item? (not no-fg-item?))
               (no-bg-item? (empty-p bg-queue))
               (bg-item? (not no-bg-item?))
               (no-processes? (empty-p processes))
               (processes? (not no-processes?))
               (no-bg-workers? (>= (size processes) *max-forks*))
               (bg-workers? (not no-bg-workers?))
               (work-to-fork? (and bg-item? bg-workers?)))
          (cond
            (;; Opportunistically reap any completed background process with no wait;
             ;; wait and reap if nothing else to do.
             (and processes?
                  (reap :wait (and (not work-to-fork?)
                                   (or no-fg-item? deterministic-order)))))
            (;; Can run stuff in the background? Keep those CPUs busy!
             work-to-fork?
             (let ((item (dequeue bg-queue)))
               (funcall announce item t)
               (let ((process (make-background-process item fun cleanup (funcall result-file item))))
                 (setf (gethash (process-pid process) processes) process)
                 (latest-stamp-f *max-actual-forks* (size processes)))))
            (;; foreground actions in non-deterministic mode? Opportunistically run one
             (and fg-item? (not deterministic-order))
             (fg-perform (dequeue fg-queue)))
            (;; foreground actions in deterministic mode after exhausting background actions?
             ;; run them all in traversal order
             (and fg-item? deterministic-order no-processes? no-bg-item?)
             (map () #'fg-perform (sort (dequeue-all fg-queue) #'< :key deterministic-order)))
            (;; Nothing to do or wait for anymore? done!
             (and no-fg-item? no-bg-item? no-processes?)
             (return))
            (t
             (assert nil (bg-queue fg-queue processes)))))))))

(defmacro doqueue/forking ((fg-queue bg-queue
                            &key variables deterministic-order
                              (announce nil) (cleanup nil) result-file)
                           &body body)
  (destructuring-bind (&key item backgroundp result condition) variables
    `(call-queue/forking
      #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,@body)
      ,fg-queue ,bg-queue
      :deterministic-order ,deterministic-order
      :result-file #'(lambda (,item) (declare (ignorable ,item)) ,result-file)
      :announce #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,announce)
      :cleanup #'(lambda (,item ,result ,condition ,backgroundp)
                   (declare (ignorable ,item ,result ,condition ,backgroundp)) ,cleanup))))
Loading