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 \f
  24 ;;;; package hacking
  25
  26 ;;; Assert that genesis preserves 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 ;;; FIXME: This nickname is a deprecated hack for backwards
  33 ;;; compatibility with code which assumed the CMU-CL-style
  34 ;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
  35 ;;; in 0.7.0, so we should get rid of this nickname after a while.
  36 (let ((package (find-package "SB-ALIEN")))
  37   (rename-package package
  38                   (package-name package)
  39                   (cons "SB-C-CALL" (package-nicknames package))))
  40
  41 (let ((package (find-package "SB-SEQUENCE")))
  42   (rename-package package (package-name package) (list "SEQUENCE")))
  43 \f
  44 ;;;; compiling and loading more of the system
  45
  46 (load "src/cold/muffler.lisp")
  47
  48 (unless (member sb-int:+empty-ht-slot+ sb-vm::*static-symbols*)
  49   ;; It doesn't "just work" to unintern the marker symbol, because then
  50   ;; then compiler thinks that equivalence-as-constant for such symbol permits
  51   ;; creation of new uninterned symbol at load-time, never mind that it was
  52   ;; accessed by way of a named global constant. Changing +EMPTY-HT-SLOT+
  53   ;; into a macro that explicitly calls LOAD-TIME-VALUE makes it work out.
  54   ;; I didn't want to think about getting this right in cold-init though.
  55   (setf (sb-int:info :variable :macro-expansion 'sb-int:+empty-ht-slot+)
  56         '(load-time-value (symbol-global-value 'sb-int:+empty-ht-slot+) t))
  57   ;; Sneaky! Now it's both a constant and a macro
  58   (setf (sb-int:info :variable :kind 'sb-int:+empty-ht-slot+) :macro))
  59
  60 (unintern sb-int:+empty-ht-slot+ (symbol-package sb-int:+empty-ht-slot+))
  61
  62 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
  63 ;;; COMPILE-PCL, at least some of which we should probably have too:
  64 ;;;
  65 ;;; (with-compilation-unit
  66 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
  67 ;;;                               #-(or high-security small) 2
  68 ;;;                               #+high-security 3)
  69 ;;;                        (speed 2) (safety #+(and (not high-security) small) 0
  70 ;;;                                          #-(or high-security small) 2
  71 ;;;                                          #+high-security 3)
  72 ;;;                        (inhibit-warnings 2))
  73 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
  74 ;;; (safety 1)
  75 ;;;                                            #+high-security (safety 3))
  76 ;;;      :context-declarations
  77 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
  78 ;;; security 3)
  79 ;;;                                             (debug #-high-security 1 #+high-s
  80 ;;; ecurity 3))))
  81 ;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
  82 ;;;     (declare (optimize (speed 0))))))
  83 ;;;
  84 ;;; FIXME: This has mutated into a hack which crudely duplicates
  85 ;;; functionality from the existing mechanism to load files from
  86 ;;; build-order.lisp-expr, without being quite parallel. (E.g. object
  87 ;;; files end up alongside the source files instead of ending up in
  88 ;;; parallel directory trees.) Maybe we could merge the filenames here
  89 ;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to
  90 ;;; indicate that the files should be handled not in cold load but
  91 ;;; afterwards.
  92 (let ((interpreter-srcs
  93               #+sb-fasteval
  94               '("SRC;INTERPRETER;MACROS"
  95                 "SRC;INTERPRETER;CHECKFUNS"
  96                 "SRC;INTERPRETER;ENV"
  97                 "SRC;INTERPRETER;SEXPR"
  98                 "SRC;INTERPRETER;SPECIAL-FORMS"
  99                 "SRC;INTERPRETER;EVAL"
 100                 "SRC;INTERPRETER;DEBUG"))
 101        (pcl-srcs
 102               '(;; CLOS, derived from the PCL reference implementation
 103                 ;;
 104                 ;; This PCL build order is based on a particular
 105                 ;; (arbitrary) linearization of the declared build
 106                 ;; order dependencies from the old PCL defsys.lisp
 107                 ;; dependency database.
 108                 #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr
 109                 #+nil "SRC;PCL;EARLY-LOW"
 110                 "SRC;PCL;MACROS"
 111                 "SRC;PCL;COMPILER-SUPPORT"
 112                 #+nil "SRC;PCL;LOW"
 113                 #+nil "SRC;PCL;SLOT-NAME" ; moved to build-order.lisp-expr
 114                 "SRC;PCL;DEFCLASS"
 115                 "SRC;PCL;DEFS"
 116                 "SRC;PCL;FNGEN"
 117                 "SRC;PCL;WRAPPER"
 118                 "SRC;PCL;CACHE"
 119                 "SRC;PCL;DLISP"
 120                 "SRC;PCL;BOOT"
 121                 "SRC;PCL;VECTOR"
 122                 "SRC;PCL;SLOTS-BOOT"
 123                 "SRC;PCL;COMBIN"
 124                 "SRC;PCL;DFUN"
 125                 "SRC;PCL;CTOR"
 126                 "SRC;PCL;BRAID"
 127                 "SRC;PCL;DLISP3"
 128                 "SRC;PCL;GENERIC-FUNCTIONS"
 129                 "SRC;PCL;SLOTS"
 130                 "SRC;PCL;INIT"
 131                 "SRC;PCL;STD-CLASS"
 132                 "SRC;PCL;CPL"
 133                 "SRC;PCL;FSC"
 134                 "SRC;PCL;METHODS"
 135                 "SRC;PCL;FIXUP"
 136                 "SRC;PCL;DEFCOMBIN"
 137                 "SRC;PCL;CTYPES"
 138                 "SRC;PCL;ENV"
 139                 "SRC;PCL;DOCUMENTATION"
 140                 "SRC;PCL;PRINT-OBJECT"
 141                 "SRC;PCL;PRECOM1"
 142                 "SRC;PCL;PRECOM2"))
 143       (other-srcs
 144               '("SRC;CODE;SETF-FUNS"
 145                 ;; miscellaneous functionality which depends on CLOS
 146                 "SRC;CODE;LATE-CONDITION"
 147
 148                 ;; CLOS-level support for the Gray OO streams
 149                 ;; extension (which is also supported by various
 150                 ;; lower-level hooks elsewhere in the code)
 151                 "SRC;PCL;GRAY-STREAMS-CLASS"
 152                 "SRC;PCL;GRAY-STREAMS"
 153
 154                 ;; CLOS-level support for User-extensible sequences.
 155                 "SRC;PCL;SEQUENCE"
 156
 157                 ;; other functionality not needed for cold init, moved
 158                 ;; to warm init to reduce peak memory requirement in
 159                 ;; cold init
 160                 "SRC;CODE;DESCRIBE"
 161
 162                 "SRC;CODE;DESCRIBE-POLICY"
 163                 "SRC;CODE;INSPECT"
 164                 "SRC;CODE;PROFILE"
 165                 "SRC;CODE;NTRACE"
 166                 "SRC;CODE;STEP"
 167                 "SRC;CODE;WARM-LIB"
 168                 #+win32 "SRC;CODE;WARM-MSWIN"
 169                 "SRC;CODE;RUN-PROGRAM"
 170
 171                 "SRC;CODE;REPACK-XREF"))
 172       (sb-c::*handled-conditions* sb-c::*handled-conditions*))
 173  (declare (special *compile-files-p*))
 174  (proclaim '(sb-ext:muffle-conditions
 175              (or (satisfies unable-to-optimize-note-p)
 176                  (satisfies optional+key-style-warning-p))))
 177  (flet
 178     ((do-srcs (list)
 179        (dolist (stem list)
 180          (let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
 181            (sb-int:/show "about to compile" fullname)
 182            (flet ((report-recompile-restart (stream)
 183                     (format stream "Recompile file ~S" fullname))
 184                   (report-continue-restart (stream)
 185                     (format stream
 186                             "Continue, using possibly bogus file ~S"
 187                             (compile-file-pathname fullname))))
 188              (tagbody
 189               retry-compile-file
 190                 (multiple-value-bind (output-truename warnings-p failure-p)
 191                     (if *compile-files-p*
 192                         (compile-file fullname)
 193                         (compile-file-pathname fullname))
 194                   (declare (ignore warnings-p))
 195                   (sb-int:/show "done compiling" fullname)
 196                   (cond ((not output-truename)
 197                          (error "COMPILE-FILE of ~S failed." fullname))
 198                         (failure-p
 199                          (unwind-protect
 200                               (restart-case
 201                                   (error "FAILURE-P was set when creating ~S."
 202                                          output-truename)
 203                                 (recompile ()
 204                                   :report report-recompile-restart
 205                                   (go retry-compile-file))
 206                                 (continue ()
 207                                   :report report-continue-restart
 208                                   (setf failure-p nil)))
 209                            ;; Don't leave failed object files lying around.
 210                            (when (and failure-p (probe-file output-truename))
 211                                  (delete-file output-truename)
 212                                  (format t "~&deleted ~S~%" output-truename))))
 213                         ;; Otherwise: success, just fall through.
 214                         (t nil))
 215                   (unless (handler-bind
 216                               ((sb-kernel:redefinition-with-defgeneric
 217                                 #'muffle-warning))
 218                             (load output-truename))
 219                     (error "LOAD of ~S failed." output-truename))
 220                   (sb-int:/show "done loading" output-truename))))))))
 221
 222   (with-compilation-unit ()
 223     (let ((*compile-print* nil))
 224       (do-srcs interpreter-srcs)))
 225   (with-compilation-unit ()
 226     (let ((*compile-print* nil))
 227       (do-srcs pcl-srcs)))
 228   (when *compile-files-p*
 229     (format t "~&; Done with PCL compilation~2%"))
 230   (do-srcs other-srcs)))
 231 \f
 232 ;;;; setting package documentation
 233
 234 ;;; While we were running on the cross-compilation host, we tried to
 235 ;;; be portable and not overwrite the doc strings for the standard
 236 ;;; packages. But now the cross-compilation host is only a receding
 237 ;;; memory, and we can have our way with the doc strings.
 238 (sb-int:/show "setting package documentation")
 239 #+sb-doc (setf (documentation (find-package "COMMON-LISP") t)
 240 "public: home of symbols defined by the ANSI language specification")
 241 #+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t)
 242                "public: the default package for user code and data")
 243 #+sb-doc (setf (documentation (find-package "KEYWORD") t)
 244                "public: home of keywords")
 245 \f