1 ;;;; cold initialization stuff, plus some other miscellaneous stuff
2 ;;;; that we don't have any better place for
4 ;;;; This software is part of the SBCL system. See the README file for
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.
13 (in-package "SB!IMPL")
15 ;;;; burning our ships behind us
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
25 ;;; FIXME: Are there other tables that need to have entries removed?
26 ;;; What about symbols of the form DEF!FOO?
27 (defun !unintern-init-only-stuff ()
28 (do ((any-changes? nil 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 (/primitive-print name)
38 ;; FIXME: Is this (FIRST (LAST *INFO-ENVIRONMENT*)) really
39 ;; meant to be an idiom to use? Is there a more obvious
40 ;; name for this? [e.g. (GLOBAL-ENVIRONMENT)?]
41 (do-info ((first (last *info-environment*))
42 :name entry :class class :type type)
43 (when (eq entry symbol)
44 (clear-info class type entry)))
45 (unintern symbol package)
46 (setf any-changes? t)))))
50 ;;;; putting ourselves out of our misery when things become too much to bear
52 (declaim (ftype (function (simple-string) nil) !cold-lose))
53 (defun !cold-lose (msg)
54 (%primitive print msg)
55 (%primitive print "too early in cold init to recover from errors")
58 ;;; last-ditch error reporting for things which should never happen
59 ;;; and which, if they do happen, are sufficiently likely to torpedo
60 ;;; the normal error-handling system that we want to bypass it
61 (declaim (ftype (function (simple-string) nil) critically-unreachable))
62 (defun critically-unreachable (where)
63 (%primitive print "internal error: Control should never reach here, i.e.")
64 (%primitive print where)
69 ;;; a list of toplevel things set by GENESIS
70 (defvar *!reversed-cold-toplevels*)
72 ;;; a SIMPLE-VECTOR set by GENESIS
73 (defvar *!load-time-values*)
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)
81 (/primitive-print ,(symbol-name name))
84 ;;; called when a cold system starts up
86 #!+sb-doc "Give the world a shove and hope it spins."
88 (/show0 "entering !COLD-INIT")
90 ;; FIXME: It'd probably be cleaner to have most of the stuff here
91 ;; handled by calls like !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 *after-gc-hooks* nil
96 *in-without-gcing* nil
99 #!+sb-thread *stop-for-gc-pending* #!+sb-thread nil
100 *allow-with-interrupts* t
101 sb!unix::*unblock-deferrables-on-enabling-interrupts-p* nil
102 *interrupts-enabled* t
103 *interrupt-pending* nil
104 *break-on-signals* nil
105 *maximum-error-depth* 10
106 *current-error-depth* 0
107 *cold-init-complete-p* nil
108 *type-system-initialized* nil
109 sb!vm:*alloc-signal* nil
110 sb!kernel::*gc-epoch* (cons nil nil))
112 ;; I'm not sure where eval is first called, so I put this first.
113 (show-and-call !eval-cold-init)
114 (show-and-call !deadline-cold-init)
115 (show-and-call thread-init-or-reinit)
116 (show-and-call !typecheckfuns-cold-init)
118 ;; Anyone might call RANDOM to initialize a hash value or something;
119 ;; and there's nothing which needs to be initialized in order for
120 ;; this to be initialized, so we initialize it right away.
121 (show-and-call !random-cold-init)
123 ;; Must be done before any non-opencoded array references are made.
124 (show-and-call !hairy-data-vector-reffer-init)
126 (show-and-call !character-database-cold-init)
127 (show-and-call !character-name-database-cold-init)
129 (show-and-call !early-package-cold-init)
130 (show-and-call !package-cold-init)
132 ;; All sorts of things need INFO and/or (SETF INFO).
133 (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT")
134 (show-and-call !globaldb-cold-init)
136 ;; This needs to be done early, but needs to be after INFO is
138 (show-and-call !function-names-cold-init)
139 (show-and-call !fdefn-cold-init)
141 ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so
142 ;; the basic type machinery needs to be initialized before toplevel
144 (show-and-call !type-class-cold-init)
145 (show-and-call !typedefs-cold-init)
146 (show-and-call !world-lock-cold-init)
147 (show-and-call !classes-cold-init)
148 (show-and-call !early-type-cold-init)
149 (show-and-call !late-type-cold-init)
150 (show-and-call !alien-type-cold-init)
151 (show-and-call !target-type-cold-init)
152 (show-and-call !vm-type-cold-init)
153 ;; FIXME: It would be tidy to make sure that that these cold init
154 ;; functions are called in the same relative order as the toplevel
155 ;; forms of the corresponding source files.
157 ;;(show-and-call !package-cold-init)
158 (show-and-call !policy-cold-init-or-resanify)
159 (/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY")
161 (show-and-call !constantp-cold-init)
162 (show-and-call !early-proclaim-cold-init)
164 ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
165 ;; fixups be done separately? Wouldn't that be clearer and better?
167 (/show0 "doing cold toplevel forms and fixups")
168 (/show0 "(LISTP *!REVERSED-COLD-TOPLEVELS*)=..")
169 (/hexstr (if (listp *!reversed-cold-toplevels*) "true" "NIL"))
170 (/show0 "about to calculate (LENGTH *!REVERSED-COLD-TOPLEVELS*)")
171 (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
172 #!+sb-show (let ((r-c-tl-length (length *!reversed-cold-toplevels*)))
173 (/show0 "(length calculated..)")
174 (let ((hexstr (hexstr r-c-tl-length)))
175 (/show0 "(hexstr calculated..)")
176 (/primitive-print hexstr)))
177 (let (#!+sb-show (index-in-cold-toplevels 0))
178 #!+sb-show (declare (type fixnum index-in-cold-toplevels))
180 (dolist (toplevel-thing (prog1
181 (nreverse *!reversed-cold-toplevels*)
182 ;; (Now that we've NREVERSEd it, it's
183 ;; somewhat scrambled, so keep anyone
184 ;; else from trying to get at it.)
185 (makunbound '*!reversed-cold-toplevels*)))
187 (when (zerop (mod index-in-cold-toplevels 1024))
188 (/show0 "INDEX-IN-COLD-TOPLEVELS=..")
189 (/hexstr index-in-cold-toplevels))
191 (setf index-in-cold-toplevels
192 (the fixnum (1+ index-in-cold-toplevels)))
193 (typecase toplevel-thing
195 (funcall toplevel-thing))
197 (case (first toplevel-thing)
199 (setf (svref *!load-time-values* (third toplevel-thing))
200 (funcall (second toplevel-thing))))
201 (:load-time-value-fixup
202 (setf (sap-ref-word (int-sap (get-lisp-obj-address (second toplevel-thing)))
203 (third toplevel-thing))
204 (get-lisp-obj-address
205 (svref *!load-time-values* (fourth toplevel-thing)))))
207 (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
208 (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
209 (/show0 "done with loop over cold toplevel forms and fixups")
211 ;; Set sane values again, so that the user sees sane values instead
212 ;; of whatever is left over from the last DECLAIM/PROCLAIM.
213 (show-and-call !policy-cold-init-or-resanify)
215 ;; Only do this after toplevel forms have run, 'cause that's where
217 (setf *type-system-initialized* t)
219 ;; now that the type system is definitely initialized, fixup UNKNOWN
220 ;; types that have crept in.
221 (show-and-call !fixup-type-cold-init)
222 ;; run the PROCLAIMs.
223 (show-and-call !late-proclaim-cold-init)
225 (show-and-call os-cold-init-or-reinit)
226 (show-and-call !pathname-cold-init)
227 (show-and-call !debug-info-cold-init)
229 (show-and-call stream-cold-init-or-reset)
230 (show-and-call !loader-cold-init)
231 (show-and-call !foreign-cold-init)
232 #!-win32 (show-and-call signal-cold-init-or-reinit)
233 (/show0 "enabling internal errors")
234 (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
236 (show-and-call float-cold-init-or-reinit)
238 (show-and-call !class-finalize)
240 ;; The reader and printer are initialized very late, so that they
241 ;; can do hairy things like invoking the compiler as part of their
243 (let ((*readtable* (make-readtable)))
244 (show-and-call !reader-cold-init)
245 (show-and-call !sharpm-cold-init)
246 (show-and-call !backq-cold-init)
247 ;; The *STANDARD-READTABLE* is assigned at last because the above
248 ;; functions would operate on the standard readtable otherwise---
249 ;; which would result in an error.
250 (setf *standard-readtable* *readtable*))
251 (setf *readtable* (copy-readtable *standard-readtable*))
252 (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
253 (sb!pretty:!pprint-cold-init)
255 ;; the ANSI-specified initial value of *PACKAGE*
256 (setf *package* (find-package "COMMON-LISP-USER"))
258 (/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
259 (setf *cold-init-complete-p* t)
261 ; hppa heap is segmented, lisp and c uses a stub to call eachother
262 #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
263 ;; The system is finally ready for GC.
264 (/show0 "enabling GC")
265 (setq *gc-inhibit* nil)
266 (/show0 "doing first GC")
268 (/show0 "back from first GC")
272 (/show0 "going into toplevel loop")
273 (handling-end-of-the-world
275 (critically-unreachable "after TOPLEVEL-INIT")))
277 (define-deprecated-function :early "1.0.56.55" quit (exit sb!thread:abort-thread)
278 (&key recklessly-p (unix-status 0))
279 (if (or recklessly-p (sb!thread:main-thread-p))
280 (exit :code unix-status :abort recklessly-p)
281 (sb!thread:abort-thread))
282 (critically-unreachable "after trying to die in QUIT"))
284 (declaim (ftype (sfunction (&key (:code (or null exit-code))
285 (:timeout (or null real))
289 (defun exit (&key code abort (timeout *exit-timeout*))
291 "Terminates the process, causing SBCL to exit with CODE. CODE
292 defaults to 0 when ABORT is false, and 1 when it is true.
294 When ABORT is false (the default), current thread is first unwound,
295 *EXIT-HOOKS* are run, other threads are terminated, and standard
296 output streams are flushed before SBCL calls exit(3) -- at which point
297 atexit(3) functions will run. If multiple threads call EXIT with ABORT
298 being false, the first one to call it will complete the protocol.
300 When ABORT is true, SBCL exits immediately by calling _exit(2) without
301 unwinding stack, or calling exit hooks. Note that _exit(2) does not
302 call atexit(3) functions unlike exit(3).
304 Recursive calls to EXIT cause EXIT to behave as it ABORT was true.
306 TIMEOUT controls waiting for other threads to terminate when ABORT is
307 NIL. Once current thread has been unwound and *EXIT-HOOKS* have been
308 run, spawning new threads is prevented and all other threads are
309 terminated by calling TERMINATE-THREAD on them. The system then waits
310 for them to finish using JOIN-THREAD with the specified TIMEOUT. If a
311 thread does not finish in TIMEOUT seconds, it is left to its own
312 devices while the exit protocol continues. TIMEOUT defaults to
313 *EXIT-TIMEOUT*, which in turn defaults to 60.
315 Note that TIMEOUT applies only to JOIN-THREAD, not *EXIT-HOOKS*. Since
316 TERMINATE-THREAD is asynchronous, getting multithreaded application
317 termination with complex cleanups right using it can be tricky. To
318 perform an orderly synchronous shutdown use an exit hook instead of
319 relying on implicit thread termination.
321 Consequences are unspecified if serious conditions occur during EXIT
322 excepting errors from *EXIT-HOOKS*, which cause warnings and stop
323 execution of the hook that signaled, but otherwise allow the exit
324 process to continue normally."
325 (if (or abort *exit-in-process*)
326 (os-exit (or code 1) :abort t)
327 (let ((code (or code 0)))
328 (with-deadline (:seconds nil :override t)
329 (sb!thread:grab-mutex *exit-lock*))
330 (setf *exit-in-process* code
331 *exit-timeout* timeout)
332 (throw '%end-of-the-world t)))
333 (critically-unreachable "After trying to die in EXIT."))
335 ;;;; initialization functions
337 (defun thread-init-or-reinit ()
338 (sb!thread::init-initial-thread)
339 (sb!thread::init-job-control)
340 (sb!thread::get-foreground))
344 (setf sb!win32::*ansi-codepage* nil)
345 (setf *default-external-format* nil)
346 (setf sb!alien::*default-c-string-external-format* nil)
347 ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
349 (os-cold-init-or-reinit)
350 (thread-init-or-reinit)
353 (signal-cold-init-or-reinit)
354 (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
355 (float-cold-init-or-reinit))
359 ;; If the debugger was disabled in the saved core, we need to
360 ;; re-disable ldb again.
361 (when (eq *invoke-debugger-hook* 'sb!debug::debugger-disabled-hook)
362 (sb!debug::disable-debugger))
363 (call-hooks "initialization" *init-hooks*))
365 ;;;; some support for any hapless wretches who end up debugging cold
368 ;;; Decode THING into hexadecimal notation using only machinery
369 ;;; available early in cold init.
371 (defun hexstr (thing)
372 (/noshow0 "entering HEXSTR")
373 (let ((addr (get-lisp-obj-address thing))
374 (str (make-string 10 :element-type 'base-char)))
375 (/noshow0 "ADDR and STR calculated")
376 (setf (char str 0) #\0
378 (/noshow0 "CHARs 0 and 1 set")
380 (/noshow0 "at head of DOTIMES loop")
381 (let* ((nibble (ldb (byte 4 0) addr))
382 (chr (char "0123456789abcdef" nibble)))
383 (declare (type (unsigned-byte 4) nibble)
385 (/noshow0 "NIBBLE and CHR calculated")
386 (setf (char str (- 9 i)) chr
387 addr (ash addr -4))))
391 (defun cold-print (x)
392 (labels ((%cold-print (obj depthoid)
394 (sb!sys:%primitive print "...")
397 (sb!sys:%primitive print obj))
399 (sb!sys:%primitive print (symbol-name obj)))
401 (sb!sys:%primitive print "cons:")
402 (let ((d (1+ depthoid)))
403 (%cold-print (car obj) d)
404 (%cold-print (cdr obj) d)))
406 (sb!sys:%primitive print (hexstr x)))))))