poiu.lisp

   1 ;; -*- mode: Lisp ; coding: utf-8 -*-
   2 ;;; This is POIU: Parallel Operator on Independent Units
   3 #+xcvb (module (:depends-on ("asdf")))
   4 (in-package :asdf)
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6 (defparameter *poiu-version* "1.30.4")
   7 (defparameter *asdf-version-required-by-poiu* "2.32"))
   8 #|
   9 POIU is a modification of ASDF that may operate on your systems in parallel.
  10 This version of POIU was designed to work with ASDF no earlier than specified.
  11
  12 POIU will notably compile each Lisp file in its own forked process,
  13 in parallel with other operations (compilation or loading).
  14 However, it will load FASLs serially as they become available.
  15
  16 POIU will only make a difference with respect to ASDF if the dependencies
  17 are not serial (i.e. no difference for systems using :serial t everywhere).
  18 You can however use Andreas Fuchs's ASDF-DEPENDENCY-GROVEL to autodetect
  19 minimal dependencies from an ASDF system (or a set of multiple such).
  20
  21 POIU may speed up compilation by utilizing all CPUs of an SMP machine.
  22 POIU may also reduce the memory pressure on the main (loading) process.
  23 POIU will enforce separation between compile- and load- time environments,
  24 helping you detect when :LOAD-TOPLEVEL is missing in EVAL-WHEN's
  25 as needed for incremental compilation even with vanilla ASDF.
  26 POIU will also catch *some* missing dependencies as exist between the
  27 files that it will happen to compile in parallel (but may not catch all
  28 dependencies that may otherwise be missing from your system).
  29
  30 When a compilation fails in a parallel process, POIU will retry compiling
  31 in the main (loading) process so you get the usual ASDF error behavior,
  32 with a chance to debug the issue and restart the operation.
  33
  34 POIU was currently only made to work with SBCL, CCL and CLISP.
  35 Porting to another Lisp implementation that supports ASDF
  36 should not be difficult. [Note: the CLISP port is somewhat less stable.]
  37 When unable to fork because the implementation is unsupported,
  38 or because multiple threads are currently in use,
  39 POIU will fall back to compiling everything in the main process.
  40
  41 Warning to CCL users: you need to save a CCL image that doesn't start threads
  42 at startup in order to use POIU (or anything that uses fork).
  43 Watch QITAB for a package that does just that: SINGLE-THREADED-CCL.
  44
  45 To use POIU, (1) make sure asdf.lisp is loaded.
  46 We require a recent enough ASDF 3; see specific requirement above.
  47 Usually, you can
  48         (require "asdf")
  49 to load ASDF 2, then
  50         (asdf:load-system "asdf")
  51 to upgrade to ASDF 3.
  52 (2) configure ASDF's SOURCE-REGISTRY or its *CENTRAL-REGISTRY*, then load POIU.
  53         (require "poiu")
  54 might work on SBCL and CCL. On CLISP, you can definitely
  55         (asdf:load-system :poiu)
  56 (alternatively, you might manually (load "/path/to/poiu"),
  57 but you might as well test your configuration of ASDF).
  58 (3) POIU is active by default. You can just
  59         (asdf:load-system :your-system)
  60 and POIU will be used to compile it.
  61 Once again, you may want to first use asdf-dependency-grovel to minimize
  62 the dependencies in your system.
  63
  64 POIU was initially written by Andreas Fuchs in 2007
  65 as part of an experiment funded by ITA Software, Inc.
  66 It was subsequently modified by Francois-Rene Rideau at ITA Software, who
  67 adapted POIU for use with XCVB in 2009, wrote the CCL and CLISP ports,
  68 moved code from POIU to ASDF, and
  69 eventually rewrote both of them together in a simpler way.
  70 The original copyright and (MIT-style) licence of ASDF (below) applies to POIU:
  71 |#
  72 ;;; ASDF is
  73 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
  74 ;;;
  75 ;;; Permission is hereby granted, free of charge, to any person obtaining
  76 ;;; a copy of this software and associated documentation files (the
  77 ;;; "Software"), to deal in the Software without restriction, including
  78 ;;; without limitation the rights to use, copy, modify, merge, publish,
  79 ;;; distribute, sublicense, and/or sell copies of the Software, and to
  80 ;;; permit persons to whom the Software is furnished to do so, subject to
  81 ;;; the following conditions:
  82 ;;;
  83 ;;; The above copyright notice and this permission notice shall be
  84 ;;; included in all copies or substantial portions of the Software.
  85 ;;;
  86 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  87 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  88 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  89 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  90 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  91 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  92 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  93
  94 (declaim (optimize (speed 1) (debug 3) (safety 3)))
  95
  96 ;;; Check versions
  97 (eval-when (:compile-toplevel :load-toplevel :execute)
  98   #-(and unix (or allegro clisp clozure sbcl))
  99   (warn "POIU doesn't support forking on your Lisp implementation (yet). Help port POIU!")
 100   (unless (or #+asdf3 (version<= *asdf-version-required-by-poiu* (asdf:asdf-version)))
 101     (error "POIU ~A requires ASDF ~A or later, but you only have ~A loaded."
 102            *poiu-version*
 103            *asdf-version-required-by-poiu* (asdf:asdf-version)))
 104   #+(and unix clisp) (ignore-errors (funcall 'require "linux"))
 105   #+(and unix sbcl) (require :sb-posix)
 106   (export '(parallel-load-system parallel-compile-system))
 107   (pushnew :poiu *features*))
 108
 109 ;;; Some general purpose data structures we use
 110 (defgeneric empty-p (collection))
 111 (defgeneric size (collection))
 112
 113 (defgeneric table-values (table))
 114 (defgeneric table-keys (table))
 115
 116 (defgeneric queue-tail (queue))
 117 (defgeneric (setf queue-tail) (new-tail queue))
 118 (defgeneric enqueue (queue value))
 119 (defgeneric enqueue-new (queue value &key test test-not))
 120 (defgeneric enqueue-in-front (queue value))
 121 (defgeneric dequeue (queue))
 122 (defgeneric enqueue-many (queue list))
 123 (defgeneric queue-contents (queue))
 124 (defgeneric dequeue-all (queue))
 125
 126 (defmethod empty-p ((x null))
 127   (declare (ignorable x))
 128   t)
 129
 130 (defmethod table-values ((table hash-table))
 131   (loop :for val :being :the :hash-values :of table :collect val))
 132 (defmethod table-keys ((table hash-table))
 133   (loop :for key :being :the :hash-keys :of table :collect key))
 134 (defmethod size ((table hash-table))
 135   (hash-table-count table))
 136 (defmethod empty-p ((table hash-table))
 137   (zerop (hash-table-count table)))
 138
 139 (defclass simple-queue ()
 140   ((head :accessor queue-head :initarg :head)))
 141 (defmethod queue-tail ((q simple-queue))
 142   (car (queue-head q)))
 143 (defmethod (setf queue-tail) (v (q simple-queue))
 144   (setf (car (queue-head q)) v))
 145 (defun simple-queue (&optional contents)
 146   (let ((c (cons 0 (copy-list contents))))
 147     (setf (car c) (last c))
 148     (make-instance 'simple-queue :head c)))
 149 (defmethod enqueue ((q simple-queue) x)
 150   (let ((c (list x)))
 151     (setf (cdr (queue-tail q)) c
 152           (queue-tail q) c)
 153     t))
 154 (defmethod enqueue-new ((q simple-queue) x &rest keys &key test test-not)
 155   (declare (ignore test test-not))
 156   (unless (apply #'find x (cdr (queue-head q)) keys)
 157     (enqueue q x)))
 158 (defmethod enqueue-in-front ((q simple-queue) x)
 159   (if (empty-p q)
 160       (enqueue q x)
 161       (push x (cdr (queue-head q))))
 162   t)
 163 (defmethod empty-p ((q simple-queue))
 164   (null (cdr (queue-head q))))
 165 (defmethod dequeue ((q simple-queue))
 166   (when (null (cdr (queue-head q)))
 167     (error "Trying to dequeue from an empty queue!"))
 168   (prog1 (pop (cdr (queue-head q)))
 169     (when (null (cdr (queue-head q)))
 170       (setf (queue-tail q) (queue-head q)))))
 171 (defmethod enqueue-many ((q simple-queue) list)
 172   (dolist (x list) (enqueue q x)) (values))
 173 (defmethod queue-contents ((q simple-queue))
 174   (copy-list (cdr (queue-head q))))
 175 (defmethod dequeue-all ((q simple-queue))
 176   (prog1 (cdr (queue-head q))
 177     (setf (queue-tail q) (queue-head q) (cdr (queue-head q)) nil)))
 178 (defun call-with-queue (fun q)
 179   (loop :until (empty-p q) :do (let ((x (dequeue q))) (funcall fun x))))
 180 (defmacro with-queue ((var qvar &optional (qval '(simple-queue))) &body body)
 181   `(let ((,qvar ,qval)) (call-with-queue (lambda (,var) ,@body) ,qvar)))
 182
 183 (defvar *parallel-plan-deterministic-p* t) ;; Use the deterministic build by default.
 184
 185 (defclass parallel-plan (plan-traversal)
 186   ((starting-points
 187     :initform (simple-queue) :reader plan-starting-points
 188     :documentation "a queue of actions with no dependencies")
 189    (children
 190     :initform (make-hash-table :test #'equal) :reader plan-children
 191     :documentation "map an action to a (hash)set of \"children\" that it depends on")
 192    (parents
 193     :initform (make-hash-table :test #'equal) :reader plan-parents
 194     :documentation "map an action to a (hash)set of \"parents\" that depend on it")
 195    (all-actions
 196     :initform (make-array '(0) :adjustable t :fill-pointer 0) :reader plan-all-actions)
 197    (deterministic-p
 198     :initform *parallel-plan-deterministic-p* :initarg :deterministic-p
 199     :type boolean :reader plan-deterministic-p
 200     :documentation "is this plan supposed to be executed in deterministic way?")))
 201
 202 (defun parallel-operate (operation system &rest keys)
 203   (apply 'operate operation system :plan-class 'parallel-plan keys))
 204 (defun parallel-load-system (system &rest args)
 205   (apply 'load-system system :plan-class 'parallel-plan args))
 206 (defun parallel-compile-system (system &rest args)
 207   (apply 'compile-system system :plan-class 'parallel-plan args))
 208 (defun parallel-build-system (system &rest args)
 209   (apply 'build-system system :plan-class 'parallel-plan args))
 210 (defun parallel-test-system (system &rest args)
 211   (apply 'test-system system :plan-class 'parallel-plan args))
 212
 213 (defmethod print-object ((plan parallel-plan) stream)
 214   (print-unreadable-object (plan stream :type t :identity t)
 215     (with-safe-io-syntax (:package :asdf)
 216       (format stream "~A" (coerce-name (plan-system plan)))
 217       #|(pprint (summarize-plan plan) stream)|#)))
 218
 219 (defmethod plan-operates-on-p ((plan parallel-plan) (component-path list))
 220   (with-slots (starting-points children) plan
 221     (let ((component (find-component () component-path)))
 222       (remove component (append (queue-contents starting-points)
 223                                 (mapcar 'node-action (action-map-keys children)))
 224               :key 'cdr :test-not 'eq))))
 225
 226 (defun action-node (action)
 227   (destructuring-bind (o . c) action
 228     (check-type o operation)
 229     (check-type c component)
 230     (cons (type-of o) c)))
 231 (defun node-action (node)
 232   (destructuring-bind (oc . c) node
 233     (check-type oc symbol)
 234     (check-type c component)
 235     (cons (make-operation oc) c)))
 236
 237 (defun make-action-map ()
 238   (make-hash-table :test 'equal))
 239 (defun action-map (map action)
 240   (gethash (action-node action) map))
 241 (defun action-unmap (map action)
 242   (remhash (action-node action) map))
 243 (defun (setf action-map) (value map action)
 244   (setf (gethash (action-node action) map) value))
 245 (defun action-map-values (map)
 246   (table-values map))
 247 (defun action-map-keys (map)
 248   (mapcar 'node-action (table-keys map)))
 249
 250 (defun record-dependency (parent child parents children)
 251   (unless (action-map parents child)
 252     (setf (action-map parents child) (make-action-map)))
 253   (when parent
 254     (unless (action-map children parent)
 255       (setf (action-map children parent) (make-action-map)))
 256     (setf (action-map (action-map children parent) child) t)
 257     (setf (action-map (action-map parents child) parent) t)))
 258
 259 (defun mark-as-done (plan operation component)
 260   ;; marks the action of operation on component as done in the deps hash-tables,
 261   ;; returns a list of new actions that are enabled by it being done.
 262   (check-type operation operation)
 263   (with-slots (starting-points parents children) plan
 264     (let* ((action (cons operation component))
 265            (action-parents (if-let (it (action-map parents action))
 266                              (action-map-keys it)))
 267            (action-children (if-let (it (action-map children action))
 268                               (action-map-keys it))))
 269       (action-unmap parents action)
 270       (action-unmap children action)
 271       (let ((enabled-parents
 272               (loop :for parent :in action-parents
 273                     :for siblings = (action-map children parent)
 274                     :do (assert siblings)
 275                         (action-unmap siblings action)
 276                     :when (empty-p siblings)
 277                       :do (action-unmap children parent)
 278                       :and :collect parent))
 279             (forlorn-children
 280               (loop :for child :in action-children
 281                     :for spouses = (action-map parents child)
 282                     :do (assert spouses)
 283                         (action-unmap spouses action)
 284                     :when (empty-p spouses)
 285                       :do (action-unmap parents child)
 286                       :and :collect child)))
 287         (loop :for enabled-action :in enabled-parents
 288             :for (e-o . e-c) = enabled-action
 289             :do (if (and (needed-in-image-p e-o e-c) (not (action-already-done-p plan e-o e-c)))
 290                     (enqueue starting-points enabled-action)
 291                     (enqueue-in-front starting-points enabled-action)))
 292         (values enabled-parents forlorn-children)))))
 293
 294 (defmethod plan-record-dependency ((plan parallel-plan) (o operation) (c component))
 295   (with-slots (children parents visiting-action-list) plan
 296     (let ((action (cons o c))
 297           (parent (first visiting-action-list)))
 298       (record-dependency parent action parents children))))
 299
 300 (defmethod (setf plan-action-status) :before
 301     (new-status (p parallel-plan) (o operation) (c component))
 302   (declare (ignorable new-status))
 303   (unless (gethash (node-for o c) (asdf/plan::plan-visited-actions p)) ; already visited?
 304     (let ((action (cons o c)))
 305       (vector-push-extend action (plan-all-actions p))
 306       (when (empty-p (action-map (plan-children p) action))
 307         (enqueue (plan-starting-points p) action)))))
 308
 309 (defgeneric* (make-parallel-plan) (operation component &key &allow-other-keys))
 310 (define-convenience-action-methods make-parallel-plan (o c &key))
 311 (defmethod make-parallel-plan ((operation operation) (component component) &rest keys &key &allow-other-keys)
 312   (let ((plan (apply 'make-instance 'parallel-plan
 313                      :system (component-system component) keys)))
 314     (traverse-action plan operation component t)
 315     plan))
 316
 317 (defun reify-action (action)
 318   (destructuring-bind (o . c) action
 319     (check-type o operation)
 320     (check-type c component)
 321     (cons (type-of o) (component-find-path c))))
 322
 323 (defun summarize-plan (plan)
 324   (with-slots (starting-points children) plan
 325     `((:starting-points
 326        ,(loop :for action :in (queue-contents starting-points)
 327               :collect (reify-action action)))
 328       (:dependencies
 329        ,(mapcar #'rest
 330                   (sort
 331                    (loop :for parent-node :being :the :hash-keys :in children
 332                          :using (:hash-value progeny)
 333                          :for parent = (node-action parent-node)
 334                          :for (o . c) = parent
 335                          :collect `(,(action-index (plan-action-status plan o c))
 336                                     ,(reify-action parent)
 337                                     ,(if (action-already-done-p plan o c) :- :+)
 338                                     ,@(loop :for child-node :being :the :hash-keys :in progeny
 339                                             :using (:hash-value v)
 340                                             :for child = (node-action child-node)
 341                                             :when v :collect (reify-action child))))
 342                    #'< :key #'first))))))
 343
 344 (defgeneric serialize-plan (plan))
 345 (defmethod serialize-plan ((plan list)) plan)
 346 (defmethod serialize-plan ((plan parallel-plan))
 347   (with-slots (all-actions visited-actions) plan
 348     (loop :for action :in (reverse (coerce all-actions 'list))
 349           :for (o . c) = action
 350           :for status = (plan-action-status plan o c)
 351           :when (action-planned-p status) :collect action)))
 352
 353 (defgeneric check-invariants (object))
 354
 355 (defmethod check-invariants ((plan parallel-plan))
 356   ;; This destructively checks that the dependency tree model is coherent.
 357   (while-collecting (collect)
 358     (with-slots (starting-points parents children) plan
 359       (with-queue (action action-queue starting-points)
 360         (collect action)
 361         (destructuring-bind (operation . component) action
 362           (mark-as-done plan operation component)))
 363       (unless (empty-p children)
 364         (error "Cycle detected in the dependency graph:~%~S"
 365                plan)))))
 366
 367 (defmethod traverse :before ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
 368   (when (eq (or plan-class *default-plan-class*) 'parallel-plan)
 369     ;; make a plan once already and destructively check it
 370     (check-invariants (apply 'make-parallel-plan o c keys))))
 371
 372 (defmethod plan-actions ((plan parallel-plan))
 373   plan)
 374
 375 (setf *default-plan-class* 'parallel-plan)
 376
 377 ;;; subprocesses: abstraction for the implementation-dependent low-level API
 378
 379 (defun disable-other-waiters ()
 380   ;; KLUDGE: Try to undo problems caused by run-program.
 381   ;; There will still be a race condition if some action calls run-program at load-time.
 382   ;; But this work-around makes it is safe to call run-program before to invoke poiu
 383   ;; (it is of course safe after). The true fix to allow run-program to be invoked
 384   ;; at load-time would be to have an API for a process-waiting callbacks.
 385   #+(and sbcl unix)
 386   (sb-sys:default-interrupt sb-unix:sigchld)) ; ignore-interrupt is undefined for SIGCHLD.
 387
 388 (defparameter *max-forks* 16) ; limit how parallel we will try to be.
 389 (defparameter *max-actual-forks* nil) ; record how parallel we actually went.
 390
 391 #+(and sbcl unix)
 392 (progn
 393 ;; Simple heuristic: if we have allocated more than the given ratio
 394 ;; of what is allowed between GCs, then trigger the GC.
 395 ;; Note: can possibly modify parameters and reset in sb-ext:*after-gc-hooks*
 396 (defparameter *prefork-allocation-reserve-ratio* .80) ; default ratio: 80%
 397 (defun can-fork-p ()
 398   (null (cdr (sb-thread:list-all-threads))))
 399 (defun should-i-gc-p ()
 400   (let ((available-bytes (- (sb-alien:extern-alien "auto_gc_trigger" sb-alien:long)
 401                             (sb-kernel:dynamic-usage)))
 402         (allocation-threshhold (sb-ext:bytes-consed-between-gcs)))
 403     (< available-bytes (* *prefork-allocation-reserve-ratio* allocation-threshhold))))
 404 (defun posix-fork ()
 405   (unless (can-fork-p)
 406     (error "Cannot fork: more than one active thread."))
 407   (when (should-i-gc-p)
 408     (sb-ext:gc))
 409   (sb-posix:fork))
 410 (defun posix-setpgrp ()
 411   (sb-posix:setpgrp))
 412 (defconstant +echild+ sb-posix:echild)
 413 (defun posix-waitpid (pid &key nohang untraced)
 414   (handler-case
 415       (sb-posix:waitpid
 416        (or pid -1)
 417        (logior (if nohang sb-posix:wnohang 0)
 418                (if untraced sb-posix:wuntraced 0)))
 419     (sb-posix:syscall-error (c)
 420       (values -1 (sb-posix:syscall-errno c)))))
 421 (defun posix-wexitstatus (x)
 422   (sb-posix:wexitstatus x))
 423 #|
 424 (defun posix-close (x)
 425   (sb-posix:close x))
 426 (defun posix-pipe ()
 427   (sb-posix:pipe))
 428 (defun fd-output-stream (fd)
 429   (sb-sys:make-fd-stream fd :output t))
 430 (defun fd-input-stream (fd)
 431   (sb-sys:make-fd-stream fd :input t))
 432 |#
 433 );sbcl
 434
 435 #+(and clozure unix)
 436 (progn
 437 (defun can-fork-p ()
 438   (null (cdr (ccl::all-processes))))
 439 (defun posix-fork ()
 440   (unless (null (cdr (ccl:all-processes)))
 441     (error "Cannot fork: more than one active thread. Are you using single-threaded-ccl?"))
 442   (ccl:external-call "fork" :int))
 443 (defun posix-setpgrp ()
 444   (ccl::external-call "setpgrp" :int))
 445 (defconstant +echild+ #.(read-from-string "#$ECHILD"))
 446 (defun posix-waitpid (pid &key nohang untraced continued)
 447   (ccl::rlet ((status :signed))
 448     (let ((retval (ccl::external-call
 449                    "waitpid"
 450                    :integer (or pid -1)
 451                    :address status
 452                    :integer (logior (if nohang #.(read-from-string "#$WNOHANG") 0)
 453                                     (if untraced #.(read-from-string "#$WUNTRACED") 0)
 454                                     (if continued #.(read-from-string "#$WCONTINUED") 0))
 455                    :signed)))
 456       (case retval
 457         (0 (values 0 ()))
 458         (-1 (values -1 (ccl::%get-errno)))
 459         (t (values retval (ccl::pref status :signed)))))))
 460 (defun posix-wexitstatus (x)
 461   (ccl::wexitstatus x))
 462 #|
 463 (defun posix-close (x)
 464   (ccl::fd-close x))
 465 (defun posix-pipe ()
 466   (ccl::pipe))
 467 (defun fd-output-stream (fd)
 468   (ccl::make-fd-stream fd :direction :output))
 469 (defun fd-input-stream (fd)
 470   (ccl::make-fd-stream fd :direction :input))
 471 |#
 472 );clozure
 473
 474 #+(and clisp unix) ;;; CLISP specific fork support
 475 (progn
 476 (defun can-fork-p ()
 477   (and (find-symbol* 'wait "POSIX" nil) (find-symbol* 'fork "LINUX" nil) t nil))
 478 (defun posix-fork ()
 479   (funcall (find-symbol* 'fork "LINUX")))
 480 (defun posix-setpgrp ()
 481   (if-let (it (find-symbol* 'setprg 'posix nil)) (funcall it)))
 482 (defun no-child-process-condition-p (c)
 483   (and (typep c 'system::simple-os-error)
 484        (equal (simple-condition-format-control c)
 485                   "UNIX error ~S (ECHILD): No child processes
 486 ")))
 487 (defconstant +echild+ :echild)
 488 (defun posix-waitpid (pid &key nohang untraced continued)
 489   (handler-case
 490       (multiple-value-bind (pid status code)
 491           (symbol-call "POSIX" 'wait :pid pid :nohang nohang :untraced untraced :continued continued)
 492         (case pid
 493           (0 (values 0 ()))
 494           (-1 (values -1 :error))
 495           (t (values pid (list pid status code)))))
 496     ((and system::simple-os-error (satisfies no-child-process-condition-p)) ()
 497       (values -1 +echild+))))
 498 (defun posix-wexitstatus (x)
 499   (if (eq :exited (second x))
 500     (third x)
 501     (cons (second x) (third x))))
 502 #|
 503 (defun posix-close (x)
 504   (LINUX:close x))
 505 (defun posix-pipe ()
 506   (multiple-value-bind (code p) (LINUX:pipe)
 507     (unless (zerop code)
 508       (error "couldn't make pipes"))
 509     (values (aref p 0) (aref p 1))))
 510 (defun fd-output-stream (fd)
 511   (ext:make-stream fd :direction :output))
 512 (defun fd-input-stream (fd)
 513   (ext:make-stream fd :direction :input))
 514 |#
 515 );clisp
 516
 517 #+(and allegro unix) ;;; Allegro specific fork support
 518 (progn
 519 (defun can-fork-p ()
 520   (null (cdr mp:*all-processes*)))
 521 (defun posix-fork ()
 522   (excl.osi:fork))
 523 (defun posix-setpgrp ()
 524   (excl.osi:setpgrp))
 525 (defconstant +echild+ excl::*echild*)
 526 (defun posix-waitpid (pid &key nohang)
 527   (multiple-value-bind (exit-status pid signal)
 528       (sys:reap-os-subprocess :pid (or pid -1) :wait (not nohang))
 529     (etypecase exit-status
 530       (null (if nohang (values 0 ()) (values -1 +echild+)))
 531       (integer (values pid (list exit-status signal))))))
 532 (defun posix-wexitstatus (x)
 533   (first x))
 534 );allegro
 535
 536 #-(or (and allegro unix) (and clisp linux) (and clozure unix) (and sbcl unix))
 537 (progn
 538 (defun can-fork-p () nil)
 539 (defun posix-fork () nil)
 540 (defun posix-setpgrp () nil)
 541 (defun posix-waitpid (pid &key &allow-other-keys) (values -1 :einval))
 542 (defun posix-wexitstatus (x) x)
 543 );unsupported implementations
 544
 545 ;;; Timing the build process
 546
 547 (defvar *time-spent-waiting* 0)
 548
 549 (defmacro timed-do ((time-accumulator) &body body)
 550   (let ((time-before-thing (gensym)))
 551     `(let ((,time-before-thing (get-internal-real-time)))
 552        (multiple-value-prog1 (progn ,@body)
 553               (incf ,time-accumulator (- (get-internal-real-time)
 554                                          ,time-before-thing))))))
 555
 556 ;;; Handling multiple processes: high-level API
 557
 558 (defclass background-process ()
 559   ((pid :initarg :pid :accessor process-pid)
 560    (data :initarg :data :accessor process-data)
 561    (cleanup :initarg :cleanup :accessor process-cleanup)
 562    ;; We pass results through a file: pipes may cause deadlocks due to full buffers and naive event loop.
 563    (result-file :initarg :result-file :accessor process-result-file)))
 564
 565 (define-condition process-failed (error)
 566   ((exit-status :initarg :exit-status)
 567    (condition :initform nil :initarg :condition)))
 568
 569 (defun process-return (result-file result condition)
 570   (with-open-file (s result-file
 571                      :direction :output :if-exists :supersede :if-does-not-exist :create)
 572     (with-safe-io-syntax ()
 573       (write (reify-simple-sexp
 574               `(:process-done
 575                 ,@(when result `(:result ,result))
 576                 ,@(when condition `(:condition ,(princ-to-string condition)))))
 577              :stream s))))
 578
 579 (defun process-result (process status)
 580   (block nil
 581     (when status
 582       (let ((exit-status (posix-wexitstatus status)))
 583         (unless (zerop exit-status)
 584           (return (values nil (make-condition 'process-failed :exit-status exit-status))))))
 585     (multiple-value-bind (form condition)
 586         (ignore-errors
 587          (with-open-file (s (process-result-file process)
 588                             :direction :input :if-does-not-exist :error)
 589            (with-safe-io-syntax ()
 590              (unreify-simple-sexp (read s)))))
 591       (when condition
 592         (return (values nil (make-condition 'process-failed :condition "Could not read result file"))))
 593       (unless (and (consp form) (eq (car form) :process-done))
 594         (return (values nil (make-condition 'process-failed :condition "Invalid result file"))))
 595       (destructuring-bind (&key result condition) (cdr form)
 596         (return (values result (when condition (make-condition 'process-failed :condition condition))))))))
 597
 598 (defun make-background-process (data function cleanup result-file)
 599   (disable-other-waiters)
 600   (finish-outputs)
 601   (let ((pid (posix-fork)))
 602     (cond
 603       ((zerop pid) ; in the child
 604        ;; don't receive the parent's SIGINTs
 605        (posix-setpgrp)
 606        #+sbcl
 607        (progn
 608          (sb-ext:disable-debugger)
 609          (when (find-package :sb-sprof)
 610            (funcall (intern "STOP-PROFILING" :sb-sprof))))
 611        #+clozure (setf ccl::*batch-flag* t)
 612        (reset-deferred-warnings)
 613        (unwind-protect
 614             (multiple-value-bind (result condition)
 615                 (ignore-errors (values (funcall function data t)))
 616               (process-return result-file result condition))
 617          (finish-outputs)
 618          (quit 0 nil)))
 619       (t ; in the parent
 620        (make-instance 'background-process
 621                       :pid pid
 622                       :result-file result-file
 623                       :cleanup cleanup
 624                       :data data)))))
 625
 626 (defun call-queue/forking (fun fg-queue bg-queue
 627                            &key announce cleanup result-file deterministic-order)
 628   ;; assumes a single-threaded parent process
 629   (declare (optimize debug))
 630   (let ((processes (make-hash-table :test 'equal)))
 631     (labels
 632         ((fg-perform (action)
 633            (funcall announce action nil)
 634            (multiple-value-bind (result condition)
 635                (ignore-errors (values (funcall fun action nil)))
 636              (funcall cleanup action result condition nil)))
 637          (cleanup-one (process status)
 638            (multiple-value-bind (result condition)
 639                (process-result process status)
 640              (funcall (process-cleanup process)
 641                       (process-data process) result condition t)))
 642          (reap (&key wait)
 643            (disable-other-waiters)
 644            (multiple-value-bind (pid status)
 645                (timed-do (*time-spent-waiting*) (posix-waitpid -1 :nohang (not wait)))
 646              (etypecase pid
 647                ((eql 0) ;; no process ended and nohang? Just return NIL.
 648                 nil)
 649                ((integer 1 *) ;; some process ended? reap it!
 650                 (let ((process (gethash pid processes)))
 651                   (assert process () "couln't find the pid ~A in processes ~S" pid (table-values processes))
 652                   (remhash pid processes)
 653                   (cleanup-one process status))
 654                 t)
 655                ((eql -1) ;; error?
 656                 (assert (eql status +echild+) (status))
 657                 ;; we were waiting for some process(es),
 658                 ;; but the OS says everything was already reaped?
 659                 ;; Our implementation or some library may have disabled the SIGCHLD signal
 660                 ;; or preempted our wait. Mark all processes as completed.
 661                 (let ((missed (table-values processes)))
 662                   (warn "No child left: we must have dropped a signal!")
 663                   (clrhash processes)
 664                   (dolist (process missed)
 665                     (cleanup-one process nil)))
 666                 t)))))
 667       (loop
 668         (let* ((no-fg-item? (empty-p fg-queue))
 669                (fg-item? (not no-fg-item?))
 670                (no-bg-item? (empty-p bg-queue))
 671                (bg-item? (not no-bg-item?))
 672                (no-processes? (empty-p processes))
 673                (processes? (not no-processes?))
 674                (no-bg-workers? (>= (size processes) *max-forks*))
 675                (bg-workers? (not no-bg-workers?))
 676                (work-to-fork? (and bg-item? bg-workers?)))
 677           (cond
 678             (;; Opportunistically reap any completed background process with no wait;
 679              ;; wait and reap if nothing else to do.
 680              (and processes?
 681                   (reap :wait (and (not work-to-fork?)
 682                                    (or no-fg-item? deterministic-order)))))
 683             (;; Can run stuff in the background? Keep those CPUs busy!
 684              work-to-fork?
 685              (let ((item (dequeue bg-queue)))
 686                (funcall announce item t)
 687                (let ((process (make-background-process item fun cleanup (funcall result-file item))))
 688                  (setf (gethash (process-pid process) processes) process)
 689                  (latest-stamp-f *max-actual-forks* (size processes)))))
 690             (;; foreground actions in non-deterministic mode? Opportunistically run one
 691              (and fg-item? (not deterministic-order))
 692              (fg-perform (dequeue fg-queue)))
 693             (;; foreground actions in deterministic mode after exhausting background actions?
 694              ;; run them all in traversal order
 695              (and fg-item? deterministic-order no-processes? no-bg-item?)
 696              (map () #'fg-perform (sort (dequeue-all fg-queue) #'< :key deterministic-order)))
 697             (;; Nothing to do or wait for anymore? done!
 698              (and no-fg-item? no-bg-item? no-processes?)
 699              (return))
 700             (t
 701              (assert nil (bg-queue fg-queue processes)))))))))
 702
 703 (defmacro doqueue/forking ((fg-queue bg-queue
 704                             &key variables deterministic-order
 705                               (announce nil) (cleanup nil) result-file)
 706                            &body body)
 707   (destructuring-bind (&key item backgroundp result condition) variables
 708     `(call-queue/forking
 709       #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,@body)
 710       ,fg-queue ,bg-queue
 711       :deterministic-order ,deterministic-order
 712       :result-file #'(lambda (,item) (declare (ignorable ,item)) ,result-file)
 713       :announce #'(lambda (,item ,backgroundp) (declare (ignorable ,item ,backgroundp)) ,announce)
 714       :cleanup #'(lambda (,item ,result ,condition ,backgroundp)
 715                    (declare (ignorable ,item ,result ,condition ,backgroundp)) ,cleanup))))
 716
 717 ;;; Performing a parallel plan
 718 (defun action-result-file (o c)
 719   (let ((p (component-pathname c)))
 720     (apply-output-translations
 721      (make-pathname :name (format nil "~A.ASDF-~A" (file-namestring p) (type-of o))
 722                     :type "process-result" :defaults p))))
 723
 724 (defun action-effectively-done-p (plan operation component &key force)
 725   (or (action-already-done-p plan operation component)
 726       (and (not force)
 727            (nth-value 1 (compute-action-stamp nil operation component)))))
 728
 729 (defmethod perform-plan ((plan parallel-plan) &key force verbose &allow-other-keys)
 730   (unless (can-fork-p)
 731     (warn #+(or clozure sbcl) "You are running threads, so it is not safe to fork. Running your build serially."
 732           #-(or clozure sbcl) "Your implementation cannot fork. Running your build serially.")
 733     (return-from perform-plan (perform-plan (serialize-plan plan))))
 734   (with-slots (starting-points children parents planned-output-action-count) plan
 735     (let* ((all-deferred-warnings nil)
 736            (ltogo (unless (zerop planned-output-action-count) (ceiling (log planned-output-action-count 10))))
 737            (fg-queue (simple-queue))
 738            (bg-queue (simple-queue)))
 739       (labels ((background-p (action)
 740                  (destructuring-bind (o . c) action
 741                    (not (or (needed-in-image-p o c)
 742                             (action-effectively-done-p plan o c :force force)))))
 743                (categorize-starting-points ()
 744                  (loop :for action :in (dequeue-all starting-points) :do
 745                    (enqueue (if (background-p action) bg-queue fg-queue) action))))
 746         (categorize-starting-points)
 747         (doqueue/forking
 748             (fg-queue bg-queue
 749              :variables (:item action :backgroundp backgroundp :result result :condition condition)
 750              :deterministic-order
 751              (when (plan-deterministic-p plan)
 752                #'(lambda (action)
 753                    (destructuring-bind (o . c) action
 754                      (action-index (plan-action-status plan o c)))))
 755              :announce
 756              (when verbose
 757                (destructuring-bind (o . c) action
 758                  (format t "~&Will ~:[try~;skip~] ~A in ~:[foreground~;background~]~%"
 759                          (action-effectively-done-p plan o c :force force)
 760                          (action-description o c) backgroundp)))
 761              :result-file
 762              (destructuring-bind (o . c) action (action-result-file o c))
 763              ;; How we cleanup in the foreground after an action is run
 764              :cleanup
 765              (destructuring-bind (o . c) action
 766                (cond
 767                  (condition
 768                   (finish-outputs)
 769                   (warn "Failed ~A~:[~; in the background~]. Retrying~:*~:[~; in the foreground~]."
 770                         (action-description o c) backgroundp)
 771                   (finish-outputs)
 772                   (perform-with-restarts o c))
 773                  (t
 774                   (mark-operation-done o c)
 775                   (destructuring-bind (&key &allow-other-keys) result)))
 776                (when backgroundp
 777                  (decf planned-output-action-count)
 778                  (format t "~&[~vd to go] Done ~A~%"
 779                          ltogo planned-output-action-count (action-description o c))
 780                  (finish-outputs))
 781                (mark-as-done plan o c)
 782                (categorize-starting-points)))
 783           ;; What we do in each forked process
 784           (destructuring-bind (o . c) action
 785             (cond
 786               (backgroundp
 787                (perform o c)
 788                `(:deferred-warnings ,(reify-deferred-warnings)))
 789               ((action-effectively-done-p plan o c)
 790                (unless (or (not (needed-in-image-p o c))
 791                            (action-already-done-p nil o c))
 792                  (warn "WTF? aedp ~A" (action-description o c)))
 793                nil)
 794               (t
 795                (perform-with-restarts o c)
 796                nil))))
 797         (mapc #'unreify-deferred-warnings all-deferred-warnings)
 798         (assert (and (empty-p fg-queue) (empty-p bg-queue) (empty-p children))
 799                 (parents children)
 800                 "Problem with the dependency graph: ~A"
 801                 (summarize-plan plan))))))
 802
 803 ;;; Breadcrumbs: feature to replay otherwise non-deterministic builds
 804 (defvar *breadcrumb-stream* nil
 805   "Stream that records the trail of operations on components.
 806 As the order of ASDF operations in general and parallel operations in
 807 particular are randomized, it is necessary to record them to replay &
 808 debug them later.")
 809 (defvar *breadcrumbs* nil
 810   "Actual breadcrumbs found, to override traversal for replay and debugging")
 811
 812 (defmethod perform :after (operation component)
 813   "Record the operations and components in a stream of breadcrumbs."
 814   (when *breadcrumb-stream*
 815     (format *breadcrumb-stream* "~S~%" (reify-action (cons operation component)))
 816     (force-output *breadcrumb-stream*)))
 817
 818 (defun read-breadcrumbs-from (operation pathname)
 819   (with-open-file (f pathname)
 820     (loop :for (op . comp) = (read f nil nil) :while op
 821           :collect (cons (find-operation operation op) (find-component () comp)))))
 822
 823 (defun call-recording-breadcrumbs (pathname record-p thunk)
 824   (if (and record-p (not *breadcrumb-stream*))
 825       (let ((*breadcrumb-stream*
 826               (progn
 827                 (delete-file-if-exists pathname)
 828                 (open pathname :direction :output
 829                                :if-exists :overwrite
 830                                :if-does-not-exist :create))))
 831         (format *breadcrumb-stream* ";; Breadcrumbs~%")
 832         (unwind-protect
 833              (funcall thunk)
 834           (close *breadcrumb-stream*)))
 835       (funcall thunk)))
 836
 837 (defmacro recording-breadcrumbs ((pathname record-p) &body body)
 838   `(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
 839
 840 (defmethod operate :before ((operation operation) system &key
 841                             (breadcrumbs-to nil record-breadcrumbs-p)
 842                             ((:using-breadcrumbs-from breadcrumb-input-pathname)
 843                              (make-broadcast-stream) read-breadcrumbs-p)
 844                             &allow-other-keys)
 845   (declare (ignorable system))
 846   (recording-breadcrumbs (breadcrumbs-to record-breadcrumbs-p)
 847     (when read-breadcrumbs-p
 848       (perform-plan (read-breadcrumbs-from operation breadcrumb-input-pathname)))))