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