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 (sb-int:logically-readonlyize
  72                            (format nil "SYS:~:@(~A~).LISP" (substitute #\; #\/ stem))
  73                            ;; indicate shareable string even if not dumped as
  74                            ;; a literal (when compiling in the LOAD step)
  75                            t))
  76                 (output
  77                   (compile-file-pathname stem
  78                    :output-file
  79                    ;; Specifying the directory name for :OUTPUT-FILE is enough.
  80                    ;; It does the right thing. (Does it work on Windows? I hope so)
  81                    (concatenate
  82                      'string sb-fasl::*!target-obj-prefix*
  83                      ;; OR: (namestring (make-pathname :directory (pathname-directory stem)))
  84                      (subseq stem 0 (1+ (position #\/ stem :from-end t)))))))
  85            (flet ((report-recompile-restart (stream)
  86                     (format stream "Recompile file ~S" stem))
  87                   (report-continue-restart (stream)
  88                     (format stream "Continue, using possibly bogus file ~S" output)))
  89              (tagbody
  90               retry-compile-file
  91                 (multiple-value-bind (output-truename warnings-p failure-p)
  92                     (ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
  93                      ((t)   (let ((sb-c::*source-namestring* fullname))
  94                               (ensure-directories-exist output)
  95                               (compile-file stem :output-file output)))
  96                      ((nil) output))
  97                   (declare (ignore warnings-p))
  98                   (cond ((not output-truename)
  99                          (error "COMPILE-FILE of ~S failed." stem))
 100                         (failure-p
 101                          (unwind-protect
 102                               (restart-case
 103                                   (error "FAILURE-P was set when creating ~S."
 104                                          output-truename)
 105                                 (recompile ()
 106                                   :report report-recompile-restart
 107                                   (go retry-compile-file))
 108                                 (continue ()
 109                                   :report report-continue-restart
 110                                   (setf failure-p nil)))
 111                            ;; Don't leave failed object files lying around.
 112                            (when (and failure-p (probe-file output-truename))
 113                                  (delete-file output-truename)
 114                                  (format t "~&deleted ~S~%" output-truename))))
 115                         ;; Otherwise: success, just fall through.
 116                         (t nil))
 117                   (unless (handler-bind
 118                               ((sb-kernel:redefinition-with-defgeneric
 119                                 #'muffle-warning))
 120                             (let ((sb-c::*source-namestring* fullname))
 121                               (load output-truename)))
 122                     (error "LOAD of ~S failed." output-truename))
 123                   (sb-int:/show "done loading" output-truename))))))))
 124
 125   (let ((*print-length* 10)
 126         (*print-level* 5)
 127         (*print-circle* t)
 128         (*compile-print* nil))
 129     (dolist (group sources)
 130       (with-compilation-unit () (do-srcs group))))))