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 (proclaim '(optimize (compilation-speed 1)
  17                      (debug #+sb-show 2 #-sb-show 1)
  18                      (inhibit-warnings 2)
  19                      (safety 2)
  20                      (space 1)
  21                      (speed 2)))
  22
  23 ;;; Assert that genesis preserved shadowing symbols.
  24 (let ((p sb-assem::*backend-instruction-set-package*))
  25   (unless (eq p (find-package "SB-VM"))
  26     (dolist (expect '("SEGMENT" "MAKE-SEGMENT"))
  27       (assert (find expect (package-shadowing-symbols p) :test 'string=)))))
  28
  29 \f
  30 ;;;; compiling and loading more of the system
  31
  32 (load "src/cold/muffler.lisp")
  33
  34 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
  35 ;;; COMPILE-PCL, at least some of which we should probably have too:
  36 ;;;
  37 ;;; (with-compilation-unit
  38 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
  39 ;;;                               #-(or high-security small) 2
  40 ;;;                               #+high-security 3)
  41 ;;;                        (speed 2) (safety #+(and (not high-security) small) 0
  42 ;;;                                          #-(or high-security small) 2
  43 ;;;                                          #+high-security 3)
  44 ;;;                        (inhibit-warnings 2))
  45 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
  46 ;;; (safety 1)
  47 ;;;                                            #+high-security (safety 3))
  48 ;;;      :context-declarations
  49 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
  50 ;;; security 3)
  51 ;;;                                             (debug #-high-security 1 #+high-s
  52 ;;; ecurity 3))))
  53 ;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
  54 ;;;     (declare (optimize (speed 0))))))
  55 ;;;
  56 ;;; FIXME: This has mutated into a hack which crudely duplicates
  57 ;;; functionality from the existing mechanism to load files from
  58 ;;; build-order.lisp-expr, without being quite parallel. (E.g. object
  59 ;;; files end up alongside the source files instead of ending up in
  60 ;;; parallel directory trees.) Maybe we could merge the filenames here
  61 ;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to
  62 ;;; indicate that the files should be handled not in cold load but
  63 ;;; afterwards.
  64 (let ((early-srcs
  65               '("SRC;CODE;WARM-ERROR"
  66                 ;; We re-nickname SB-SEQUENCE as SEQUENCE now.
  67                 ;; It could be done in genesis, but not earlier,
  68                 ;; since the host has a package of that name.
  69                 "SRC;CODE;DEFPACKAGE"))
  70
  71       (interpreter-srcs
  72               #+sb-fasteval
  73               '("SRC;INTERPRETER;MACROS"
  74                 "SRC;INTERPRETER;CHECKFUNS"
  75                 "SRC;INTERPRETER;ENV"
  76                 "SRC;INTERPRETER;SEXPR"
  77                 "SRC;INTERPRETER;SPECIAL-FORMS"
  78                 "SRC;INTERPRETER;EVAL"
  79                 "SRC;INTERPRETER;DEBUG"))
  80        (pcl-srcs
  81               '(;; CLOS, derived from the PCL reference implementation
  82                 ;;
  83                 ;; This PCL build order is based on a particular
  84                 ;; (arbitrary) linearization of the declared build
  85                 ;; order dependencies from the old PCL defsys.lisp
  86                 ;; dependency database.
  87                 #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr
  88                 #+nil "SRC;PCL;EARLY-LOW"
  89                 "SRC;PCL;MACROS"
  90                 "SRC;PCL;COMPILER-SUPPORT"
  91                 #+nil "SRC;PCL;LOW"
  92                 #+nil "SRC;PCL;SLOT-NAME" ; moved to build-order.lisp-expr
  93                 "SRC;PCL;DEFCLASS"
  94                 "SRC;PCL;DEFS"
  95                 "SRC;PCL;FNGEN"
  96                 "SRC;PCL;WRAPPER"
  97                 "SRC;PCL;CACHE"
  98                 "SRC;PCL;DLISP"
  99                 "SRC;PCL;BOOT"
 100                 "SRC;PCL;VECTOR"
 101                 "SRC;PCL;SLOTS-BOOT"
 102                 "SRC;PCL;COMBIN"
 103                 "SRC;PCL;DFUN"
 104                 "SRC;PCL;CTOR"
 105                 "SRC;PCL;BRAID"
 106                 "SRC;PCL;DLISP3"
 107                 "SRC;PCL;GENERIC-FUNCTIONS"
 108                 "SRC;PCL;SLOTS"
 109                 "SRC;PCL;INIT"
 110                 "SRC;PCL;STD-CLASS"
 111                 "SRC;PCL;CPL"
 112                 "SRC;PCL;FSC"
 113                 "SRC;PCL;METHODS"
 114                 "SRC;PCL;FIXUP"
 115                 "SRC;PCL;DEFCOMBIN"
 116                 "SRC;PCL;CTYPES"
 117                 "SRC;PCL;ENV"
 118                 "SRC;PCL;DOCUMENTATION"
 119                 "SRC;PCL;PRINT-OBJECT"
 120                 "SRC;PCL;PRECOM1"
 121                 "SRC;PCL;PRECOM2"))
 122       (other-srcs
 123               '("SRC;CODE;SETF-FUNS"
 124                 ;; miscellaneous functionality which depends on CLOS
 125                 "SRC;CODE;LATE-CONDITION"
 126
 127                 ;; CLOS-level support for the Gray OO streams
 128                 ;; extension (which is also supported by various
 129                 ;; lower-level hooks elsewhere in the code)
 130                 "SRC;PCL;GRAY-STREAMS-CLASS"
 131                 "SRC;PCL;GRAY-STREAMS"
 132
 133                 ;; CLOS-level support for User-extensible sequences.
 134                 "SRC;PCL;SEQUENCE"
 135
 136                 ;; other functionality not needed for cold init, moved
 137                 ;; to warm init to reduce peak memory requirement in
 138                 ;; cold init
 139                 "SRC;CODE;DESCRIBE"
 140
 141                 "SRC;CODE;DESCRIBE-POLICY"
 142                 "SRC;CODE;INSPECT"
 143                 "SRC;CODE;PROFILE"
 144                 "SRC;CODE;NTRACE"
 145                 "SRC;CODE;STEP"
 146                 "SRC;CODE;WARM-LIB"
 147                 #+win32 "SRC;CODE;WARM-MSWIN"
 148                 "SRC;CODE;RUN-PROGRAM"
 149                 #+sb-traceroot "SRC;CODE;TRACEROOT"
 150
 151                 #+immobile-code "SRC;CODE;IMMOBILE-CODE"
 152                 "SRC;CODE;REPACK-XREF"))
 153       (sb-c::*handled-conditions* sb-c::*handled-conditions*))
 154  (declare (special *compile-files-p*))
 155  (proclaim '(sb-ext:muffle-conditions
 156              (or (satisfies unable-to-optimize-note-p)
 157                  (satisfies optional+key-style-warning-p))))
 158  (flet
 159     ((do-srcs (list)
 160        (dolist (stem list)
 161          (let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
 162            (sb-int:/show "about to compile" fullname)
 163            (flet ((report-recompile-restart (stream)
 164                     (format stream "Recompile file ~S" fullname))
 165                   (report-continue-restart (stream)
 166                     (format stream
 167                             "Continue, using possibly bogus file ~S"
 168                             (compile-file-pathname fullname))))
 169              (tagbody
 170               retry-compile-file
 171                 (multiple-value-bind (output-truename warnings-p failure-p)
 172                     (ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
 173                      ((t)   (compile-file fullname))
 174                      ((nil) (compile-file-pathname fullname)))
 175                   (declare (ignore warnings-p))
 176                   (sb-int:/show "done compiling" fullname)
 177                   (cond ((not output-truename)
 178                          (error "COMPILE-FILE of ~S failed." fullname))
 179                         (failure-p
 180                          (unwind-protect
 181                               (restart-case
 182                                   (error "FAILURE-P was set when creating ~S."
 183                                          output-truename)
 184                                 (recompile ()
 185                                   :report report-recompile-restart
 186                                   (go retry-compile-file))
 187                                 (continue ()
 188                                   :report report-continue-restart
 189                                   (setf failure-p nil)))
 190                            ;; Don't leave failed object files lying around.
 191                            (when (and failure-p (probe-file output-truename))
 192                                  (delete-file output-truename)
 193                                  (format t "~&deleted ~S~%" output-truename))))
 194                         ;; Otherwise: success, just fall through.
 195                         (t nil))
 196                   (unless (handler-bind
 197                               ((sb-kernel:redefinition-with-defgeneric
 198                                 #'muffle-warning))
 199                             (load output-truename))
 200                     (error "LOAD of ~S failed." output-truename))
 201                   (sb-int:/show "done loading" output-truename))))))))
 202
 203   (let ((*print-length* 10)
 204         (*print-level* 5)
 205         (*print-circle* t)
 206         (*compile-print* nil))
 207     (do-srcs early-srcs)
 208     (with-compilation-unit () (do-srcs interpreter-srcs))
 209     (with-compilation-unit () (do-srcs pcl-srcs))
 210     (do-srcs other-srcs))))