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   (show-and-call !globaldb-cold-init)
 118
 119   ;; This needs to be done early, but needs to be after INFO is
 120   ;; initialized.
 121   (show-and-call !fdefn-cold-init)
 122
 123   ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so
 124   ;; the basic type machinery needs to be initialized before toplevel
 125   ;; forms run.
 126   (show-and-call !type-class-cold-init)
 127   (show-and-call !typedefs-cold-init)
 128   (show-and-call !classes-cold-init)
 129   (show-and-call !early-type-cold-init)
 130   (show-and-call !late-type-cold-init)
 131   (show-and-call !alien-type-cold-init)
 132   (show-and-call !target-type-cold-init)
 133   (show-and-call !vm-type-cold-init)
 134   ;; FIXME: It would be tidy to make sure that that these cold init
 135   ;; functions are called in the same relative order as the toplevel
 136   ;; forms of the corresponding source files.
 137
 138   (show-and-call !package-cold-init)
 139
 140   ;; Set sane values for our toplevel forms.
 141   (show-and-call !set-sane-cookie-defaults)
 142
 143   ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
 144   ;; fixups be done separately? Wouldn't that be clearer and better?
 145   ;; -- WHN 19991204
 146   (/show0 "doing cold toplevel forms and fixups")
 147   (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
 148   #!+sb-show (%primitive print
 149                          (sb!impl::hexstr (length *!reversed-cold-toplevels*)))
 150   (let (#!+sb-show (index-in-cold-toplevels 0)
 151         #!+sb-show (filename-in-cold-toplevels nil))
 152     #!+sb-show (declare (type fixnum index-in-cold-toplevels))
 153     (dolist (toplevel-thing (prog1
 154                                 (nreverse *!reversed-cold-toplevels*)
 155                               ;; (Now that we've NREVERSEd it, it's
 156                               ;; somewhat scrambled, so keep anyone
 157                               ;; else from trying to get at it.)
 158                               (makunbound '*!reversed-cold-toplevels*)))
 159       #!+sb-show
 160       (when (zerop (mod index-in-cold-toplevels 1024))
 161         (/show0 "INDEX-IN-COLD-TOPLEVELS=..")
 162         (%primitive print (sb!impl::hexstr index-in-cold-toplevels)))
 163       #!+sb-show
 164       (setf index-in-cold-toplevels
 165             (the fixnum (1+ index-in-cold-toplevels)))
 166       (typecase toplevel-thing
 167         (function
 168          (funcall toplevel-thing))
 169         (cons
 170          (case (first toplevel-thing)
 171            (:load-time-value
 172             (setf (svref *!load-time-values* (third toplevel-thing))
 173                   (funcall (second toplevel-thing))))
 174            (:load-time-value-fixup
 175             #!-gengc
 176             (setf (sap-ref-32 (second toplevel-thing) 0)
 177                   (get-lisp-obj-address
 178                    (svref *!load-time-values* (third toplevel-thing))))
 179             #!+gengc
 180             (do-load-time-value-fixup (second toplevel-thing)
 181                                       (third  toplevel-thing)
 182                                       (fourth toplevel-thing)))
 183            #!+(and x86 gencgc)
 184            (:load-time-code-fixup
 185             (sb!vm::do-load-time-code-fixup (second toplevel-thing)
 186                                             (third  toplevel-thing)
 187                                             (fourth toplevel-thing)
 188                                             (fifth  toplevel-thing)))
 189            (t
 190             (%primitive print
 191                         "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")
 192             (%halt))))
 193         (t
 194          (%primitive print "bogus function in *!REVERSED-COLD-TOPLEVELS*")
 195          (%halt)))))
 196   (/show0 "done with loop over cold toplevel forms and fixups")
 197
 198   ;; Set sane values again, so that the user sees sane values instead of
 199   ;; whatever is left over from the last DECLAIM.
 200   (show-and-call !set-sane-cookie-defaults)
 201
 202   ;; Only do this after top level forms have run, 'cause that's where
 203   ;; DEFTYPEs are.
 204   (setf *type-system-initialized* t)
 205
 206   (show-and-call os-cold-init-or-reinit)
 207   (show-and-call !filesys-cold-init)
 208
 209   (show-and-call stream-cold-init-or-reset)
 210   (show-and-call !loader-cold-init)
 211   (show-and-call signal-cold-init-or-reinit)
 212   (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
 213
 214   ;; FIXME: This list of modes should be defined in one place and
 215   ;; explicitly shared between here and REINIT.
 216   (set-floating-point-modes :traps '(:overflow
 217                                      #!-x86 :underflow
 218                                      :invalid
 219                                      :divide-by-zero))
 220
 221   (show-and-call !class-finalize)
 222
 223   ;; The reader and printer are initialized very late, so that they
 224   ;; can even do hairy things like invoking the compiler as part of
 225   ;; their initialization.
 226   (show-and-call !reader-cold-init)
 227   (let ((*readtable* *standard-readtable*))
 228     (show-and-call !sharpm-cold-init)
 229     (show-and-call !backq-cold-init))
 230   (setf *readtable* (copy-readtable *standard-readtable*))
 231   (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
 232   (sb!pretty:!pprint-cold-init)
 233
 234   ;; the ANSI-specified initial value of *PACKAGE*
 235   (setf *package* (find-package "COMMON-LISP-USER"))
 236   ;; FIXME: I'm not sure where it should be done, but CL-USER really
 237   ;; ought to USE-PACKAGE publicly accessible packages like SB-DEBUG
 238   ;; (for ARG and VAR), SB-EXT, SB-EXT-C-CALL, and SB-EXT-ALIEN so
 239   ;; that the user has a hint about which symbols we consider public.
 240   ;; (Perhaps SB-DEBUG wouldn't need to be in the list if ARG and VAR
 241   ;; could be typed directly, with no parentheses, at the debug prompt
 242   ;; the way that e.g. F or BACKTRACE can be?)
 243
 244   (/show0 "done initializing")
 245   (setf *cold-init-complete-p* t)
 246
 247   ;; Unintern no-longer-needed stuff before we GC.
 248   #!-sb-fluid
 249   (!unintern-init-only-stuff)
 250
 251   ;; The system is finally ready for GC.
 252   #!-gengc (setf *already-maybe-gcing* nil)
 253   (/show0 "enabling GC")
 254   (gc-on)
 255   (/show0 "doing first GC")
 256   (gc :full t)
 257   (/show0 "back from first GC")
 258
 259   ;; The show is on.
 260   (terpri)
 261   (/show0 "going into toplevel loop")
 262   (let ((wot (catch '%end-of-the-world
 263                (/show0 "inside CATCH '%END-OF-THE-WORLD")
 264                (toplevel))))
 265     (flush-standard-output-streams)
 266     (sb!unix:unix-exit wot)))
 267
 268 (defun quit (&key recklessly-p
 269                   (unix-code 0 unix-code-p)
 270                   (unix-status unix-code))
 271   #!+sb-doc
 272   "Terminate the current Lisp. Things are cleaned up (with UNWIND-PROTECT
 273   and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
 274   UNIX-STATUS is used as the status code."
 275   (declare (type (signed-byte 32) unix-code))
 276   ;; TO DO: UNIX-CODE was deprecated in sbcl-0.6.8, after having been
 277   ;; around for less than a year. It should be safe to remove it after
 278   ;; a year.
 279   (when unix-code-p
 280     (warn "The UNIX-CODE argument is deprecated. Use the UNIX-STATUS argument
 281 instead (which is another name for the same thing)."))
 282   (if recklessly-p
 283       (sb!unix:unix-exit unix-status)
 284       (throw '%end-of-the-world unix-code)))
 285 \f
 286 ;;;; initialization functions
 287
 288 (defun reinit ()
 289   (without-interrupts
 290     (without-gcing
 291       (os-cold-init-or-reinit)
 292       (stream-reinit)
 293       (signal-cold-init-or-reinit)
 294       (gc-cold-init-or-reinit)
 295       (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
 296       (set-floating-point-modes :traps
 297                                 ;; PRINT seems to not like x86 NPX denormal
 298                                 ;; floats like LEAST-NEGATIVE-SINGLE-FLOAT, so
 299                                 ;; the :UNDERFLOW exceptions are disabled by
 300                                 ;; default. Joe User can explicitly enable them
 301                                 ;; if desired.
 302                                 '(:overflow #!-x86 :underflow :invalid
 303                                             :divide-by-zero))
 304       ;; Clear pseudo atomic in case this core wasn't compiled with
 305       ;; support.
 306       ;;
 307       ;; FIXME: In SBCL our cores are always compiled with support. So
 308       ;; we don't need to do this, do we? At least not for this
 309       ;; reason.. (Perhaps we should do it anyway in case someone
 310       ;; manages to save an image from within a pseudo-atomic-atomic
 311       ;; operation?)
 312       #!+x86 (setf sb!impl::*pseudo-atomic-atomic* 0))
 313     (gc-on)))
 314 \f
 315 ;;;; some support for any hapless wretches who end up debugging cold
 316 ;;;; init code
 317
 318 ;;; Decode THING into hex using only machinery available early in cold
 319 ;;; init.
 320 #!+sb-show
 321 (defun hexstr (thing)
 322   (let ((addr (sb!kernel:get-lisp-obj-address thing))
 323         (str (make-string 10)))
 324     (setf (char str 0) #\0
 325           (char str 1) #\x)
 326     (dotimes (i 8)
 327       (let* ((nibble (ldb (byte 4 0) addr))
 328              (chr (char "0123456789abcdef" nibble)))
 329         (declare (type (unsigned-byte 4) nibble)
 330                  (base-char chr))
 331         (setf (char str (- 9 i)) chr
 332               addr (ash addr -4))))
 333     str))
 334
 335 #!+sb-show
 336 (defun cold-print (x)
 337   (typecase x
 338     (simple-string (sb!sys:%primitive print x))
 339     (symbol (sb!sys:%primitive print (symbol-name x)))
 340     (list (let ((count 0))
 341             (sb!sys:%primitive print "list:")
 342             (dolist (i x)
 343               (when (>= (incf count) 4)
 344                 (sb!sys:%primitive print "...")
 345                 (return))
 346               (cold-print i))))
 347     (t (sb!sys:%primitive print (hexstr x)))))