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