src/cold/compile-cold-sbcl.lisp

   1 ;;;; Compile the fundamental system sources (not CLOS, and possibly
   2 ;;;; not some other warm-load-only stuff like DESCRIBE) to produce
   3 ;;;; object files. Also set *TARGET-OBJECT-FILES* to all of their
   4 ;;;; names.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB-COLD")
  16
  17 (defvar *target-object-file-names*)
  18
  19 ;;; Evaluate compile-time effects only
  20 (when (make-host-2-parallelism)
  21   (require :sb-posix))
  22 #+#.(cl:if (cl:find-package "SB-POSIX") '(and) '(or))
  23 (defun parallel-make-host-2 (max-jobs)
  24   (let ((reversed-target-object-file-names nil)
  25         (subprocess-count 0)
  26         (subprocess-list nil))
  27     (flet ((wait ()
  28              (multiple-value-bind (pid status) (sb-posix:wait)
  29                (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
  30                (setq subprocess-list (delete pid subprocess-list)))
  31              (decf subprocess-count)))
  32       (do-stems-and-flags (stem flags)
  33         (unless (position :not-target flags)
  34           (when (>= subprocess-count max-jobs)
  35             (wait))
  36           (let ((pid (sb-posix:fork)))
  37             (when (zerop pid)
  38               (target-compile-stem stem flags)
  39               ;; FIXME: convey exit code based on COMPILE result.
  40               (sb-sys:os-exit 0))
  41             (push pid subprocess-list))
  42           (incf subprocess-count)
  43           ;; Cause the compile-time effects from this file
  44           ;; to appear in subsequently forked children.
  45           (let ((*compile-for-effect-only* t))
  46             (target-compile-stem stem flags))
  47           (push (stem-object-path stem flags :target-compile)
  48                 reversed-target-object-file-names)))
  49       (loop (if (plusp subprocess-count) (wait) (return)))
  50       (nreverse reversed-target-object-file-names))))
  51
  52 ;;; Actually compile
  53 (setf *target-object-file-names*
  54       (if (make-host-2-parallelism)
  55           (parallel-make-host-2 (make-host-2-parallelism))
  56           (let ((reversed-target-object-file-names nil))
  57             (do-stems-and-flags (stem flags)
  58               (unless (position :not-target flags)
  59                 (push (target-compile-stem stem flags)
  60                       reversed-target-object-file-names)
  61                 #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
  62             (nreverse reversed-target-object-file-names))))