src/code/cold-init.lisp

   1 ;;;; cold initialization stuff, plus some other miscellaneous stuff
   2 ;;;; that we don't have any better place for
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 (file-comment
  16   "$Header$")
  17 \f
  18 ;;;; burning our ships behind us
  19
  20 ;;; There's a fair amount of machinery which is needed only at cold
  21 ;;; init time, and should be discarded before freezing the final
  22 ;;; system. We discard it by uninterning the associated symbols.
  23 ;;; Rather than using a special table of symbols to be uninterned,
  24 ;;; which might be tedious to maintain, instead we use a hack:
  25 ;;; anything whose name matches a magic character pattern is
  26 ;;; uninterned.
  27 (defun !unintern-init-only-stuff ()
  28   (do ((any-changes? nil nil))
  29       (nil)
  30     (dolist (package (list-all-packages))
  31       (do-symbols (symbol package)
  32         (let ((name (symbol-name symbol)))
  33           (when (or (string= name "!" :end1 1 :end2 1)
  34                     (and (>= (length name) 2)
  35                          (string= name "*!" :end1 2 :end2 2)))
  36             (/show0 "uninterning cold-init-only symbol..")
  37             #!+sb-show (%primitive print name)
  38             (unintern symbol package)
  39             (setf any-changes? t)))))
  40     (unless any-changes?
  41       (return))))
  42 \f
  43 ;;;; !COLD-INIT
  44
  45 ;;; a list of toplevel things set by GENESIS
  46 (defvar *!reversed-cold-toplevels*)
  47
  48 ;;; a SIMPLE-VECTOR set by genesis
  49 (defvar *!load-time-values*)
  50
  51 #!+gengc
  52 (defun do-load-time-value-fixup (object offset index)
  53   (declare (type index offset))
  54   (macrolet ((lose (msg)
  55                `(progn
  56                   (%primitive print ,msg)
  57                   (%halt))))
  58     (let ((value (svref *!load-time-values* index)))
  59       (typecase object
  60         (list
  61          (case offset
  62            (0 (setf (car object) value))
  63            (1 (setf (cdr object) value))
  64            (t (lose "bogus offset in cons cell"))))
  65         (instance
  66          (setf (%instance-ref object (- offset sb!vm:instance-slots-offset))
  67                value))
  68         (code-component
  69          (setf (code-header-ref object offset) value))
  70         (simple-vector
  71          (setf (svref object (- offset sb!vm:vector-data-offset)) value))
  72         (t
  73          (lose "unknown kind of object for load-time-value fixup"))))))
  74
  75 (eval-when (:compile-toplevel :execute)
  76   ;; FIXME: Perhaps we should make SHOW-AND-CALL-AND-FMAKUNBOUND, too,
  77   ;; and use it for most of the cold-init functions. (Just be careful
  78   ;; not to use it for the COLD-INIT-OR-REINIT functions.)
  79   (sb!xc:defmacro show-and-call (name)
  80     `(progn
  81        #!+sb-show (%primitive print ,(symbol-name name))
  82        (,name))))
  83
  84 ;;; called when a cold system starts up
  85 (defun !cold-init ()
  86   #!+sb-doc "Give the world a shove and hope it spins."
  87
  88   (/show0 "entering !COLD-INIT")
  89
  90   ;; FIXME: It'd probably be cleaner to have most of the stuff here
  91   ;; handled by calls a la !GC-COLD-INIT, !ERROR-COLD-INIT, and
  92   ;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
  93   ;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
  94   ;; be explicitly set in order to be meaningful.
  95   (setf *gc-verbose* nil)
  96   (setf *gc-notify-stream* nil)
  97   (setf *before-gc-hooks* nil)
  98   (setf *after-gc-hooks* nil)
  99   #!+gengc (setf sb!conditions::*handler-clusters* nil)
 100   #!-gengc (setf *already-maybe-gcing* t
 101                  *gc-inhibit* t
 102                  *need-to-collect-garbage* nil
 103                  sb!unix::*interrupts-enabled* t
 104                  sb!unix::*interrupt-pending* nil)
 105   (setf *break-on-signals* nil)
 106   (setf *maximum-error-depth* 10)
 107   (setf *current-error-depth* 0)
 108   (setf *cold-init-complete-p* nil)
 109   (setf *type-system-initialized* nil)
 110
 111   ;; Anyone might call RANDOM to initialize a hash value or something;
 112   ;; and there's nothing which needs to be initialized in order for
 113   ;; this to be initialized, so we initialize it right away.
 114   (show-and-call !random-cold-init)
 115
 116   ;; All sorts of things need INFO and/or (SETF INFO).
 117   (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT")
 118   (show-and-call !globaldb-cold-init)
 119
 120   ;; This needs to be done early, but needs to be after INFO is
 121   ;; initialized.
 122   (show-and-call !fdefn-cold-init)
 123
 124   ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so
 125   ;; the basic type machinery needs to be initialized before toplevel
 126   ;; forms run.
 127   (show-and-call !type-class-cold-init)
 128   (show-and-call !typedefs-cold-init)
 129   (show-and-call !classes-cold-init)
 130   (show-and-call !early-type-cold-init)
 131   (show-and-call !late-type-cold-init)
 132   (show-and-call !alien-type-cold-init)
 133   (show-and-call !target-type-cold-init)
 134   (show-and-call !vm-type-cold-init)
 135   ;; FIXME: It would be tidy to make sure that that these cold init
 136   ;; functions are called in the same relative order as the toplevel
 137   ;; forms of the corresponding source files.
 138
 139   (show-and-call !package-cold-init)
 140
 141   ;; Set sane values for our toplevel forms.
 142   (show-and-call !set-sane-cookie-defaults)
 143
 144   ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
 145   ;; fixups be done separately? Wouldn't that be clearer and better?
 146   ;; -- WHN 19991204
 147   (/show0 "doing cold toplevel forms and fixups")
 148   (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
 149   #!+sb-show (%primitive print
 150                          (sb!impl::hexstr (length *!reversed-cold-toplevels*)))
 151   (let (#!+sb-show (index-in-cold-toplevels 0)
 152         #!+sb-show (filename-in-cold-toplevels nil))
 153     #!+sb-show (declare (type fixnum index-in-cold-toplevels))
 154     (dolist (toplevel-thing (prog1
 155                                 (nreverse *!reversed-cold-toplevels*)
 156                               ;; (Now that we've NREVERSEd it, it's
 157                               ;; somewhat scrambled, so keep anyone
 158                               ;; else from trying to get at it.)
 159                               (makunbound '*!reversed-cold-toplevels*)))
 160       #!+sb-show
 161       (when (zerop (mod index-in-cold-toplevels 1024))
 162         (/show0 "INDEX-IN-COLD-TOPLEVELS=..")
 163         (%primitive print (sb!impl::hexstr index-in-cold-toplevels)))
 164       #!+sb-show
 165       (setf index-in-cold-toplevels
 166             (the fixnum (1+ index-in-cold-toplevels)))
 167       (typecase toplevel-thing
 168         (function
 169          (funcall toplevel-thing))
 170         (cons
 171          (case (first toplevel-thing)
 172            (:load-time-value
 173             (setf (svref *!load-time-values* (third toplevel-thing))
 174                   (funcall (second toplevel-thing))))
 175            (:load-time-value-fixup
 176             #!-gengc
 177             (setf (sap-ref-32 (second toplevel-thing) 0)
 178                   (get-lisp-obj-address
 179                    (svref *!load-time-values* (third toplevel-thing))))
 180             #!+gengc
 181             (do-load-time-value-fixup (second toplevel-thing)
 182                                       (third  toplevel-thing)
 183                                       (fourth toplevel-thing)))
 184            #!+(and x86 gencgc)
 185            (:load-time-code-fixup
 186             (sb!vm::do-load-time-code-fixup (second toplevel-thing)
 187                                             (third  toplevel-thing)
 188                                             (fourth toplevel-thing)
 189                                             (fifth  toplevel-thing)))
 190            (t
 191             (%primitive print
 192                         "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")
 193             (%halt))))
 194         (t
 195          (%primitive print "bogus function in *!REVERSED-COLD-TOPLEVELS*")
 196          (%halt)))))
 197   (/show0 "done with loop over cold toplevel forms and fixups")
 198
 199   ;; Set sane values again, so that the user sees sane values instead of
 200   ;; whatever is left over from the last DECLAIM.
 201   (show-and-call !set-sane-cookie-defaults)
 202
 203   ;; Only do this after top level forms have run, 'cause that's where
 204   ;; DEFTYPEs are.
 205   (setf *type-system-initialized* t)
 206
 207   (show-and-call os-cold-init-or-reinit)
 208   (show-and-call !filesys-cold-init)
 209
 210   (show-and-call stream-cold-init-or-reset)
 211   (show-and-call !loader-cold-init)
 212   (show-and-call signal-cold-init-or-reinit)
 213   (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
 214
 215   ;; FIXME: This list of modes should be defined in one place and
 216   ;; explicitly shared between here and REINIT.
 217   (set-floating-point-modes :traps '(:overflow
 218                                      #!-x86 :underflow
 219                                      :invalid
 220                                      :divide-by-zero))
 221
 222   (show-and-call !class-finalize)
 223
 224   ;; The reader and printer are initialized very late, so that they
 225   ;; can even do hairy things like invoking the compiler as part of
 226   ;; their initialization.
 227   (show-and-call !reader-cold-init)
 228   (let ((*readtable* *standard-readtable*))
 229     (show-and-call !sharpm-cold-init)
 230     (show-and-call !backq-cold-init))
 231   (setf *readtable* (copy-readtable *standard-readtable*))
 232   (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
 233   (sb!pretty:!pprint-cold-init)
 234
 235   ;; the ANSI-specified initial value of *PACKAGE*
 236   (setf *package* (find-package "COMMON-LISP-USER"))
 237   ;; FIXME: I'm not sure where it should be done, but CL-USER really
 238   ;; ought to USE-PACKAGE publicly accessible packages like SB-DEBUG
 239   ;; (for ARG and VAR), SB-EXT, SB-EXT-C-CALL, and SB-EXT-ALIEN so
 240   ;; that the user has a hint about which symbols we consider public.
 241   ;; (Perhaps SB-DEBUG wouldn't need to be in the list if ARG and VAR
 242   ;; could be typed directly, with no parentheses, at the debug prompt
 243   ;; the way that e.g. F or BACKTRACE can be?)
 244
 245   (/show0 "done initializing")
 246   (setf *cold-init-complete-p* t)
 247
 248   ;; Unintern no-longer-needed stuff before we GC.
 249   #!-sb-fluid
 250   (!unintern-init-only-stuff)
 251
 252   ;; The system is finally ready for GC.
 253   #!-gengc (setf *already-maybe-gcing* nil)
 254   (/show0 "enabling GC")
 255   (gc-on)
 256   (/show0 "doing first GC")
 257   (gc :full t)
 258   (/show0 "back from first GC")
 259
 260   ;; The show is on.
 261   (terpri)
 262   (/show0 "going into toplevel loop")
 263   (let ((wot (catch '%end-of-the-world
 264                (/show0 "inside CATCH '%END-OF-THE-WORLD")
 265                (toplevel))))
 266     (flush-standard-output-streams)
 267     (sb!unix:unix-exit wot)))
 268
 269 (defun quit (&key recklessly-p
 270                   (unix-code 0 unix-code-p)
 271                   (unix-status unix-code))
 272   #!+sb-doc
 273   "Terminate the current Lisp. Things are cleaned up (with UNWIND-PROTECT
 274   and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
 275   UNIX-STATUS is used as the status code."
 276   (declare (type (signed-byte 32) unix-code))
 277   ;; TO DO: UNIX-CODE was deprecated in sbcl-0.6.8, after having been
 278   ;; around for less than a year. It should be safe to remove it after
 279   ;; a year.
 280   (when unix-code-p
 281     (warn "The UNIX-CODE argument is deprecated. Use the UNIX-STATUS argument
 282 instead (which is another name for the same thing)."))
 283   (if recklessly-p
 284       (sb!unix:unix-exit unix-status)
 285       (throw '%end-of-the-world unix-code)))
 286 \f
 287 ;;;; initialization functions
 288
 289 (defun reinit ()
 290   (without-interrupts
 291     (without-gcing
 292       (os-cold-init-or-reinit)
 293       (stream-reinit)
 294       (signal-cold-init-or-reinit)
 295       (gc-cold-init-or-reinit)
 296       (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
 297       (set-floating-point-modes :traps
 298                                 ;; PRINT seems to not like x86 NPX denormal
 299                                 ;; floats like LEAST-NEGATIVE-SINGLE-FLOAT, so
 300                                 ;; the :UNDERFLOW exceptions are disabled by
 301                                 ;; default. Joe User can explicitly enable them
 302                                 ;; if desired.
 303                                 '(:overflow #!-x86 :underflow :invalid
 304                                             :divide-by-zero))
 305       ;; Clear pseudo atomic in case this core wasn't compiled with
 306       ;; support.
 307       ;;
 308       ;; FIXME: In SBCL our cores are always compiled with support. So
 309       ;; we don't need to do this, do we? At least not for this
 310       ;; reason.. (Perhaps we should do it anyway in case someone
 311       ;; manages to save an image from within a pseudo-atomic-atomic
 312       ;; operation?)
 313       #!+x86 (setf sb!impl::*pseudo-atomic-atomic* 0))
 314     (gc-on)))
 315 \f
 316 ;;;; some support for any hapless wretches who end up debugging cold
 317 ;;;; init code
 318
 319 ;;; Decode THING into hex using only machinery available early in cold
 320 ;;; init.
 321 #!+sb-show
 322 (defun hexstr (thing)
 323   (let ((addr (sb!kernel:get-lisp-obj-address thing))
 324         (str (make-string 10)))
 325     (setf (char str 0) #\0
 326           (char str 1) #\x)
 327     (dotimes (i 8)
 328       (let* ((nibble (ldb (byte 4 0) addr))
 329              (chr (char "0123456789abcdef" nibble)))
 330         (declare (type (unsigned-byte 4) nibble)
 331                  (base-char chr))
 332         (setf (char str (- 9 i)) chr
 333               addr (ash addr -4))))
 334     str))
 335
 336 #!+sb-show
 337 (defun cold-print (x)
 338   (typecase x
 339     (simple-string (sb!sys:%primitive print x))
 340     (symbol (sb!sys:%primitive print (symbol-name x)))
 341     (list (let ((count 0))
 342             (sb!sys:%primitive print "list:")
 343             (dolist (i x)
 344               (when (>= (incf count) 4)
 345                 (sb!sys:%primitive print "...")
 346                 (return))
 347               (cold-print i))))
 348     (t (sb!sys:%primitive print (hexstr x)))))