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 #+#.(cl:if (cl:find-package "SB-POSIX") '(and) '(or))
  21 (defun parallel-make-host-2 (max-jobs)
  22   (let ((reversed-target-object-file-names nil)
  23         (subprocess-count 0)
  24         (subprocess-list nil))
  25     (flet ((wait ()
  26              (multiple-value-bind (pid status) (sb-posix:wait)
  27                (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
  28                (setq subprocess-list (delete pid subprocess-list)))
  29              (decf subprocess-count)))
  30       (do-stems-and-flags (stem flags)
  31         (unless (position :not-target flags)
  32           (when (>= subprocess-count max-jobs)
  33             (wait))
  34           (let ((pid (sb-posix:fork)))
  35             (when (zerop pid)
  36               (target-compile-stem stem flags)
  37               ;; FIXME: convey exit code based on COMPILE result.
  38               (sb-cold::exit-process 0))
  39             (push pid subprocess-list))
  40           (incf subprocess-count)
  41           ;; Cause the compile-time effects from this file
  42           ;; to appear in subsequently forked children.
  43           (let ((*compile-for-effect-only* t))
  44             (target-compile-stem stem flags))
  45           (unless (find :not-genesis flags)
  46             (push (stem-object-path stem flags :target-compile)
  47                   reversed-target-object-file-names))))
  48       (loop (if (plusp subprocess-count) (wait) (return)))
  49       (nreverse reversed-target-object-file-names))))
  50
  51 ;;; Actually compile
  52 (setf *target-object-file-names*
  53       (if (make-host-2-parallelism)
  54           (parallel-make-host-2 (make-host-2-parallelism))
  55           (let ((reversed-target-object-file-names nil))
  56             (do-stems-and-flags (stem flags)
  57               (unless (position :not-target flags)
  58                 (let ((filename (target-compile-stem stem flags)))
  59                   (unless (position :not-genesis flags)
  60                     (push filename reversed-target-object-file-names)))
  61                 #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
  62             (nreverse reversed-target-object-file-names))))