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 ;;; Our cross-compilation host is out of the picture now, so we no
  27 ;;; longer need to worry about collisions between our package names
  28 ;;; and cross-compilation host package names, so now is a good time to
  29 ;;; rename any package with a bootstrap-only name SB!FOO to its
  30 ;;; permanent name SB-FOO.
  31 ;;;
  32 ;;; (In principle it might be tidier to do this when dumping the cold
  33 ;;; image in genesis, but in practice the logic might be a little
  34 ;;; messier because genesis dumps both symbols and packages, and we'd
  35 ;;; need to make sure that dumped symbols were renamed in the same way
  36 ;;; as dumped packages. Or we could do it in cold init, but it's
  37 ;;; easier to experiment with and debug things here in warm init than
  38 ;;; in cold init, so we do it here instead.)
  39 (let ((boot-prefix "SB!")
  40       (perm-prefix "SB-"))
  41   (dolist (package (list-all-packages))
  42     (let ((old-package-name (package-name package)))
  43       (when (and (>= (length old-package-name) (length boot-prefix))
  44                  (string= boot-prefix old-package-name
  45                           :end2 (length boot-prefix)))
  46         (let ((new-package-name (concatenate 'string
  47                                              perm-prefix
  48                                              (subseq old-package-name
  49                                                      (length boot-prefix)))))
  50           (rename-package package
  51                           new-package-name
  52                           (package-nicknames package)))))))
  53
  54 ;;; FIXME: This nickname is a deprecated hack for backwards
  55 ;;; compatibility with code which assumed the CMU-CL-style
  56 ;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
  57 ;;; in 0.7.0, so we should get rid of this nickname after a while.
  58 (let ((package (find-package "SB-ALIEN")))
  59   (rename-package package
  60                   (package-name package)
  61                   (cons "SB-C-CALL" (package-nicknames package))))
  62
  63 (let ((package (find-package "SB-SEQUENCE")))
  64   (rename-package package (package-name package) (list "SEQUENCE")))
  65 \f
  66 ;;;; compiling and loading more of the system
  67
  68 (load "src/cold/muffler.lisp")
  69
  70 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
  71 ;;; COMPILE-PCL, at least some of which we should probably have too:
  72 ;;;
  73 ;;; (with-compilation-unit
  74 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
  75 ;;;                               #-(or high-security small) 2
  76 ;;;                               #+high-security 3)
  77 ;;;                        (speed 2) (safety #+(and (not high-security) small) 0
  78 ;;;                                          #-(or high-security small) 2
  79 ;;;                                          #+high-security 3)
  80 ;;;                        (inhibit-warnings 2))
  81 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
  82 ;;; (safety 1)
  83 ;;;                                            #+high-security (safety 3))
  84 ;;;      :context-declarations
  85 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
  86 ;;; security 3)
  87 ;;;                                             (debug #-high-security 1 #+high-s
  88 ;;; ecurity 3))))
  89 ;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
  90 ;;;     (declare (optimize (speed 0))))))
  91 ;;;
  92 ;;; FIXME: This has mutated into a hack which crudely duplicates
  93 ;;; functionality from the existing mechanism to load files from
  94 ;;; build-order.lisp-expr, without being quite parallel. (E.g. object
  95 ;;; files end up alongside the source files instead of ending up in
  96 ;;; parallel directory trees.) Maybe we could merge the filenames here
  97 ;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to
  98 ;;; indicate that the files should be handled not in cold load but
  99 ;;; afterwards.
 100 (let ((pcl-srcs
 101               '(;; CLOS, derived from the PCL reference implementation
 102                 ;;
 103                 ;; This PCL build order is based on a particular
 104                 ;; (arbitrary) linearization of the declared build
 105                 ;; order dependencies from the old PCL defsys.lisp
 106                 ;; dependency database.
 107                 #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr
 108                 #+nil "SRC;PCL;EARLY-LOW"
 109                 "SRC;PCL;MACROS"
 110                 "SRC;PCL;COMPILER-SUPPORT"
 111                 #+nil "SRC;PCL;LOW"
 112                 #+nil "SRC;PCL;SLOT-NAME" ; moved to build-order.lisp-expr
 113                 "SRC;PCL;DEFCLASS"
 114                 "SRC;PCL;DEFS"
 115                 "SRC;PCL;FNGEN"
 116                 "SRC;PCL;WRAPPER"
 117                 "SRC;PCL;CACHE"
 118                 "SRC;PCL;DLISP"
 119                 "SRC;PCL;BOOT"
 120                 "SRC;PCL;VECTOR"
 121                 "SRC;PCL;SLOTS-BOOT"
 122                 "SRC;PCL;COMBIN"
 123                 "SRC;PCL;DFUN"
 124                 "SRC;PCL;CTOR"
 125                 "SRC;PCL;BRAID"
 126                 "SRC;PCL;DLISP3"
 127                 "SRC;PCL;GENERIC-FUNCTIONS"
 128                 "SRC;PCL;SLOTS"
 129                 "SRC;PCL;INIT"
 130                 "SRC;PCL;STD-CLASS"
 131                 "SRC;PCL;CPL"
 132                 "SRC;PCL;FSC"
 133                 "SRC;PCL;METHODS"
 134                 "SRC;PCL;FIXUP"
 135                 "SRC;PCL;DEFCOMBIN"
 136                 "SRC;PCL;CTYPES"
 137                 "SRC;PCL;ENV"
 138                 "SRC;PCL;DOCUMENTATION"
 139                 "SRC;PCL;PRINT-OBJECT"
 140                 "SRC;PCL;PRECOM1"
 141                 "SRC;PCL;PRECOM2"))
 142       (other-srcs
 143               '(;; miscellaneous functionality which depends on CLOS
 144                 "SRC;CODE;FORCE-DELAYED-DEFBANGMETHODS"
 145                 "SRC;CODE;LATE-CONDITION"
 146
 147                 ;; CLOS-level support for the Gray OO streams
 148                 ;; extension (which is also supported by various
 149                 ;; lower-level hooks elsewhere in the code)
 150                 "SRC;PCL;GRAY-STREAMS-CLASS"
 151                 "SRC;PCL;GRAY-STREAMS"
 152
 153                 ;; CLOS-level support for User-extensible sequences.
 154                 "SRC;PCL;SEQUENCE"
 155
 156                 ;; other functionality not needed for cold init, moved
 157                 ;; to warm init to reduce peak memory requirement in
 158                 ;; cold init
 159                 "SRC;CODE;DESCRIBE"
 160                 "SRC;CODE;DESCRIBE-POLICY"
 161                 "SRC;CODE;INSPECT"
 162                 "SRC;CODE;PROFILE"
 163                 "SRC;CODE;NTRACE"
 164                 "SRC;CODE;STEP"
 165                 "SRC;CODE;WARM-LIB"
 166                 #+win32 "SRC;CODE;WARM-MSWIN"
 167                 "SRC;CODE;RUN-PROGRAM"))
 168       (sb-c::*handled-conditions* sb-c::*handled-conditions*))
 169  (declare (special *compile-files-p*))
 170  (proclaim '(sb-ext:muffle-conditions
 171              (or (satisfies unable-to-optimize-note-p)
 172                  (satisfies optional+key-style-warning-p))))
 173  (flet
 174     ((do-srcs (list)
 175        (dolist (stem list)
 176          (let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
 177            (sb-int:/show "about to compile" fullname)
 178            (flet ((report-recompile-restart (stream)
 179                     (format stream "Recompile file ~S" fullname))
 180                   (report-continue-restart (stream)
 181                     (format stream
 182                             "Continue, using possibly bogus file ~S"
 183                             (compile-file-pathname fullname))))
 184              (tagbody
 185               retry-compile-file
 186                 (multiple-value-bind (output-truename warnings-p failure-p)
 187                     (if *compile-files-p*
 188                         (compile-file fullname)
 189                         (compile-file-pathname fullname))
 190                   (declare (ignore warnings-p))
 191                   (sb-int:/show "done compiling" fullname)
 192                   (cond ((not output-truename)
 193                          (error "COMPILE-FILE of ~S failed." fullname))
 194                         (failure-p
 195                          (unwind-protect
 196                               (restart-case
 197                                   (error "FAILURE-P was set when creating ~S."
 198                                          output-truename)
 199                                 (recompile ()
 200                                   :report report-recompile-restart
 201                                   (go retry-compile-file))
 202                                 (continue ()
 203                                   :report report-continue-restart
 204                                   (setf failure-p nil)))
 205                            ;; Don't leave failed object files lying around.
 206                            (when (and failure-p (probe-file output-truename))
 207                                  (delete-file output-truename)
 208                                  (format t "~&deleted ~S~%" output-truename))))
 209                         ;; Otherwise: success, just fall through.
 210                         (t nil))
 211                   (unless (handler-bind
 212                               ((sb-kernel:redefinition-with-defgeneric
 213                                 #'muffle-warning))
 214                             (load output-truename))
 215                     (error "LOAD of ~S failed." output-truename))
 216                   (sb-int:/show "done loading" output-truename))))))))
 217
 218    (let* ((ppd (copy-pprint-dispatch))
 219           (sb-debug:*debug-print-variable-alist*
 220            (list (cons '*print-pprint-dispatch* ppd)))
 221           (*print-pprint-dispatch* ppd))
 222      (set-pprint-dispatch
 223       'sb-kernel:layout (lambda (stream obj)
 224                           (print-unreadable-object (obj stream :type t)
 225                             (write (sb-int:awhen (sb-kernel:layout-classoid obj)
 226                                      (sb-kernel:classoid-name sb-int:it))
 227                                    :stream stream))))
 228      (set-pprint-dispatch
 229       'sb-kernel:classoid (lambda (stream obj)
 230                             (print-unreadable-object (obj stream :type t)
 231                               (write (sb-kernel:classoid-name obj) :stream stream))))
 232      (set-pprint-dispatch
 233       'sb-kernel:ctype (lambda (stream obj)
 234                          (print-unreadable-object (obj stream :type t)
 235                            (prin1 (sb-kernel:type-specifier obj) stream))))
 236      (set-pprint-dispatch
 237       'package (lambda (stream obj)
 238                  (print-unreadable-object (obj stream :type t)
 239                    (write (package-name obj) :stream stream))))
 240      (set-pprint-dispatch
 241       'pathname (lambda (stream obj)
 242                   (write-string "#P" stream)
 243                   (write (namestring obj) :stream stream)))
 244      (set-pprint-dispatch
 245       'sb-thread:thread (lambda (stream obj)
 246                           (declare (ignore obj))
 247                           (write-string "#<main-thread>" stream)))
 248      (set-pprint-dispatch
 249       'restart (lambda (stream obj)
 250                  (print-unreadable-object (obj stream :type t :identity t)
 251                    (write (restart-name obj) :stream stream))))
 252      ;; These next two are coded in a totally brittle way, but no more wrong
 253      ;; than typing the decoding expressions into the debugger to decipher
 254      ;; a backtrace. Anyway, if it ceases to print right, just fix it again!
 255      (set-pprint-dispatch
 256       'generic-function
 257       (lambda (stream obj)
 258         (format stream "<~S ~S>" (type-of obj)
 259                 (svref (sb-kernel:%funcallable-instance-info obj 1) 5))))
 260      (set-pprint-dispatch
 261       'class
 262       (lambda (stream obj)
 263         (format stream "<~S ~S>" (type-of obj)
 264                 (svref (sb-kernel:%instance-ref obj 1) 3))))
 265      (with-compilation-unit ()
 266        (let ((*compile-print* nil))
 267          (do-srcs pcl-srcs)))
 268      (when *compile-files-p*
 269        (format t "~&; Done with PCL compilation~2%"))
 270      (do-srcs other-srcs))))
 271 \f
 272 ;;;; setting package documentation
 273
 274 ;;; While we were running on the cross-compilation host, we tried to
 275 ;;; be portable and not overwrite the doc strings for the standard
 276 ;;; packages. But now the cross-compilation host is only a receding
 277 ;;; memory, and we can have our way with the doc strings.
 278 (sb-int:/show "setting package documentation")
 279 #+sb-doc (setf (documentation (find-package "COMMON-LISP") t)
 280 "public: home of symbols defined by the ANSI language specification")
 281 #+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t)
 282                "public: the default package for user code and data")
 283 #+sb-doc (setf (documentation (find-package "KEYWORD") t)
 284                "public: home of keywords")
 285 \f
 286