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               #.(if (eq :external
  41                         (nth-value 1 (find-symbol "OS-EXIT" :sb-sys)))
  42                     `(,(find-symbol "OS-EXIT" :sb-sys) 0)
  43                     `(sb-unix:unix-exit 0)))
  44             (push pid subprocess-list))
  45           (incf subprocess-count)
  46           ;; Cause the compile-time effects from this file
  47           ;; to appear in subsequently forked children.
  48           (let ((*compile-for-effect-only* t))
  49             (target-compile-stem stem flags))
  50           (unless (find :not-genesis flags)
  51             (push (stem-object-path stem flags :target-compile)
  52                   reversed-target-object-file-names))))
  53       (loop (if (plusp subprocess-count) (wait) (return)))
  54       (nreverse reversed-target-object-file-names))))
  55
  56 ;;; Actually compile
  57 (setf *target-object-file-names*
  58       (if (make-host-2-parallelism)
  59           (parallel-make-host-2 (make-host-2-parallelism))
  60           (let ((reversed-target-object-file-names nil))
  61             (do-stems-and-flags (stem flags)
  62               (unless (position :not-target flags)
  63                 (let ((filename (target-compile-stem stem flags)))
  64                   (unless (position :not-genesis flags)
  65                     (push filename reversed-target-object-file-names)))
  66                 #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
  67             (nreverse reversed-target-object-file-names))))