src/cold/warm.lisp

   1 ;;;; "warm initialization": initialization which comes after cold init
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "COMMON-LISP-USER")
  13 \f
  14 ;;;; general warm init compilation policy
  15
  16 (assert (zerop (deref (extern-alien "lowtag_for_widetag" (array char 64))
  17                       (ash sb-vm:character-widetag -2))))
  18
  19 (proclaim '(optimize (compilation-speed 1)
  20                      (debug #+sb-show 2 #-sb-show 1)
  21                      (inhibit-warnings 2)
  22                      (safety 2)
  23                      (space 1)
  24                      (speed 2)))
  25
  26 ;;; Assert that genesis preserved shadowing symbols.
  27 (let ((p sb-assem::*backend-instruction-set-package*))
  28   (unless (eq p (find-package "SB-VM"))
  29     (dolist (expect '("SEGMENT" "MAKE-SEGMENT"))
  30       (assert (find expect (package-shadowing-symbols p) :test 'string=)))))
  31
  32 \f
  33 ;;;; compiling and loading more of the system
  34
  35 (load "src/cold/muffler.lisp")
  36
  37 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
  38 ;;; COMPILE-PCL, at least some of which we should probably have too:
  39 ;;;
  40 ;;; (with-compilation-unit
  41 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
  42 ;;;                               #-(or high-security small) 2
  43 ;;;                               #+high-security 3)
  44 ;;;                        (speed 2) (safety #+(and (not high-security) small) 0
  45 ;;;                                          #-(or high-security small) 2
  46 ;;;                                          #+high-security 3)
  47 ;;;                        (inhibit-warnings 2))
  48 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
  49 ;;; (safety 1)
  50 ;;;                                            #+high-security (safety 3))
  51 ;;;      :context-declarations
  52 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
  53 ;;; security 3)
  54 ;;;                                             (debug #-high-security 1 #+high-s
  55 ;;; ecurity 3))))
  56 ;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
  57 ;;;     (declare (optimize (speed 0))))))
  58 ;;;
  59 (let ((sources (with-open-file (f "build-order.lisp-expr")
  60                  (let ((*features* (cons :warm-build-phase *features*)))
  61                    (read f))))
  62       (sb-c::*handled-conditions* sb-c::*handled-conditions*))
  63  (declare (special *compile-files-p*))
  64  (proclaim '(sb-ext:muffle-conditions
  65              (or (satisfies unable-to-optimize-note-p)
  66                  (satisfies optional+key-style-warning-p))))
  67  (flet ((do-srcs (list)
  68          (dolist (stem list)
  69           ;; Do like SB-COLD::LPNIFY-STEM for consistency, though parse/xlate/unparse
  70           ;; would probably also work. I don't think that's better.
  71           (let ((fullname (format nil "SYS:~:@(~A~).LISP" (substitute #\; #\/ stem)))
  72                 (output
  73                   (compile-file-pathname stem
  74                    :output-file
  75                    ;; Specifying the directory name for :OUTPUT-FILE is enough.
  76                    ;; It does the right thing. (Does it work on Windows? I hope so)
  77                    (truename
  78                     (concatenate
  79                      'string sb-fasl::*!target-obj-prefix*
  80                      ;; OR: (namestring (make-pathname :directory (pathname-directory stem)))
  81                      (subseq stem 0 (1+ (position #\/ stem :from-end t))))))))
  82            (flet ((report-recompile-restart (stream)
  83                     (format stream "Recompile file ~S" stem))
  84                   (report-continue-restart (stream)
  85                     (format stream "Continue, using possibly bogus file ~S" output)))
  86              (tagbody
  87               retry-compile-file
  88                 (multiple-value-bind (output-truename warnings-p failure-p)
  89                     (ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
  90                      ((t)   (let ((sb-c::*source-namestring* fullname))
  91                               (compile-file stem :output-file output)))
  92                      ((nil) output))
  93                   (declare (ignore warnings-p))
  94                   (cond ((not output-truename)
  95                          (error "COMPILE-FILE of ~S failed." stem))
  96                         (failure-p
  97                          (unwind-protect
  98                               (restart-case
  99                                   (error "FAILURE-P was set when creating ~S."
 100                                          output-truename)
 101                                 (recompile ()
 102                                   :report report-recompile-restart
 103                                   (go retry-compile-file))
 104                                 (continue ()
 105                                   :report report-continue-restart
 106                                   (setf failure-p nil)))
 107                            ;; Don't leave failed object files lying around.
 108                            (when (and failure-p (probe-file output-truename))
 109                                  (delete-file output-truename)
 110                                  (format t "~&deleted ~S~%" output-truename))))
 111                         ;; Otherwise: success, just fall through.
 112                         (t nil))
 113                   (unless (handler-bind
 114                               ((sb-kernel:redefinition-with-defgeneric
 115                                 #'muffle-warning))
 116                             (let ((sb-c::*source-namestring* fullname))
 117                               (load output-truename)))
 118                     (error "LOAD of ~S failed." output-truename))
 119                   (sb-int:/show "done loading" output-truename))))))))
 120
 121   (let ((*print-length* 10)
 122         (*print-level* 5)
 123         (*print-circle* t)
 124         (*compile-print* nil))
 125     (dolist (group sources)
 126       (with-compilation-unit () (do-srcs group))))))