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
24 ;;; Additionally, you can specify an arbitrary way to destroy
25 ;;; random bootstrap stuff on per-package basis.
26 (defun !unintern-init-only-stuff
()
27 (dolist (package (list-all-packages))
28 (awhen (find-symbol "UNINTERN-INIT-ONLY-STUFF" package
)
29 (format t
"~&Calling ~/sb-impl::print-symbol-with-prefix/~%" it
)
31 (unintern it package
)))
32 (flet ((uninternable-p (symbol)
33 (let ((name (symbol-name symbol
)))
34 (or (and (>= (length name
) 1) (char= (char name
0) #\
!))
35 (and (>= (length name
) 2) (string= name
"*!" :end1
2))
37 ;; DEF!METHOD need no longer be accessible,
38 ;; but *DELAYED-DEF!METHOD-ARGS* remains,
39 ;; due to a reference from pcl/methods.lisp.
40 ;; It would be nice to fix that.
42 sb
!c
::sb
!pcl sb
!c
::sb
!impl sb
!c
::sb
!kernel
43 sb
!c
::sb
!c sb
!c
::sb
!int
))))))
44 ;; A structure constructor name, in particular !MAKE-SAETP,
45 ;; can't be uninterned if referenced by a defstruct-description.
46 ;; So loop over all structure classoids and clobber any
47 ;; symbol that should be uninternable.
48 (maphash (lambda (classoid layout
)
49 (when (structure-classoid-p classoid
)
50 (let ((dd (layout-info layout
)))
51 (setf (dd-constructors dd
)
52 (delete-if (lambda (x)
53 (and (consp x
) (uninternable-p (car x
))))
54 (dd-constructors dd
))))))
55 (classoid-subclasses (find-classoid t
)))
56 ;; Todo: perform one pass, then a full GC, then a final pass to confirm
57 ;; it worked. It shoud be an error if any uninternable symbols remain,
58 ;; but at present there are about 13 other "!" symbols with referers.
59 (with-package-iterator (iter (list-all-packages) :internal
:external
)
60 (loop (multiple-value-bind (winp symbol accessibility package
) (iter)
61 (declare (ignore accessibility
))
64 (when (uninternable-p symbol
)
65 ;; Uninternable symbols which are referenced by other stuff
66 ;; can't disappear from the image, but we don't need to preserve
67 ;; their functions, so FMAKUNBOUND them. This doesn't have
68 ;; the intended effect if the function shares a code-component
69 ;; with non-cold-init lambdas. Though the cold-init function is
70 ;; never called post-build, it is not discarded. Also, I suspect
71 ;; that the following loop should print nothing, but it does:
73 (sb-vm::map-allocated-objects
74 (lambda (obj type size
)
75 (declare (ignore size
))
76 (when (= type sb-vm
:code-header-widetag
)
77 (let ((name (sb-c::debug-info-name
78 (sb-kernel:%code-debug-info obj
))))
79 (when (and (stringp name
) (search "COLD-INIT-FORMS" name
))
84 (unintern symbol package
)))))))
86 ;;;; putting ourselves out of our misery when things become too much to bear
88 (declaim (ftype (function (simple-string) nil
) !cold-lose
))
89 (defun !cold-lose
(msg)
90 (%primitive print msg
)
91 (%primitive print
"too early in cold init to recover from errors")
94 ;;; last-ditch error reporting for things which should never happen
95 ;;; and which, if they do happen, are sufficiently likely to torpedo
96 ;;; the normal error-handling system that we want to bypass it
97 (declaim (ftype (function (simple-string) nil
) critically-unreachable
))
98 (defun critically-unreachable (where)
99 (%primitive print
"internal error: Control should never reach here, i.e.")
100 (%primitive print where
)
105 ;;; a list of toplevel things set by GENESIS
106 (defvar *!cold-toplevels
*) ; except for DEFUNs and SETF macros
107 (defvar *!cold-setf-macros
*) ; just SETF macros
108 (defvar *!cold-defconstants
*) ; just DEFCONSTANT-EQXs
109 (defvar *!cold-defuns
*) ; just DEFUNs
111 ;;; a SIMPLE-VECTOR set by GENESIS
112 (defvar *!load-time-values
*)
114 (eval-when (:compile-toplevel
:execute
)
115 ;; FIXME: Perhaps we should make SHOW-AND-CALL-AND-FMAKUNBOUND, too,
116 ;; and use it for most of the cold-init functions. (Just be careful
117 ;; not to use it for the COLD-INIT-OR-REINIT functions.)
118 (sb!xc
:defmacro show-and-call
(name)
120 (/primitive-print
,(symbol-name name
))
123 (defun !encapsulate-stuff-for-cold-init
(&aux names
)
124 (flet ((encapsulate-1 (name handler
)
125 (encapsulate name
'!cold-init handler
)
127 (encapsulate-1 '%failed-aver
129 ;; output the message before signaling error,
130 ;; as it may be this is too early in the cold init.
132 (write-line "failed AVER:")
139 (lambda (f designator
)
140 (cond ((packagep designator
) designator
)
141 (t (funcall f
(let ((s (string designator
)))
142 (if (eql (mismatch s
"SB!") 3)
143 (concatenate 'string
"SB-" (subseq s
3))
146 ;; Wrap thing-defining-functions that style-warn sufficiently early
147 ;; that HANDLER-BIND can't be used to suppress the warning
148 ;; (since condition classoids don't exist yet).
149 (flet ((warning-suppressor (signaler)
150 (lambda (f &rest args
)
151 (encapsulate signaler
'!cold-init
(constantly nil
))
153 (unencapsulate signaler
'!cold-init
)))) ; Restore it.
154 ;; %DEFUN complains about everything being redefined
155 (encapsulate-1 '%defun
(warning-suppressor 'warn
))
156 ;; %DEFCONSTANT complains about all named types because of earmuffs.
157 (encapsulate-1 'sb
!c
::%defconstant
(warning-suppressor 'style-warn
))
158 ;; %DEFSETF ',FN warns when #'(SETF fn) also has a function binding.
159 (encapsulate-1 '%defsetf
(warning-suppressor 'style-warn
))))
162 (defmacro !with-init-wrappers
(&rest forms
)
163 `(let ((wrapped-functions (!encapsulate-stuff-for-cold-init
)))
165 (dolist (f wrapped-functions
) (unencapsulate f
'!cold-init
))))
167 ;;; called when a cold system starts up
169 #!+sb-doc
"Give the world a shove and hope it spins."
172 (sb!int
::cannot-
/show
"Test of CANNOT-/SHOW [don't worry - this is expected]")
173 (/show0
"entering !COLD-INIT")
174 (setq *readtable
* (make-readtable)
176 *previous-readtable-case
* nil
177 *print-length
* 6 *print-level
* 3)
179 (write-string "COLD-INIT... "
180 (setq *error-output
* (!make-cold-stderr-stream
)
181 *standard-output
* *error-output
*
182 *trace-output
* *error-output
*))
184 ;; Assert that FBOUNDP doesn't choke when its answer is NIL.
185 ;; It was fine if T because in that case the legality of the arg is certain.
186 ;; And be extra paranoid - ensure that it really gets called.
187 (locally (declare (notinline fboundp
)) (fboundp '(setf !zzzzzz
)))
189 ;; Putting data in a synchronized hashtable (*PACKAGE-NAMES*)
190 ;; requires that the main thread be properly initialized.
191 (show-and-call thread-init-or-reinit
)
192 ;; Printing of symbols requires that packages be filled in, because
193 ;; OUTPUT-SYMBOL calls FIND-SYMBOL to determine accessibility.
194 (show-and-call !package-cold-init
)
195 ;; Fill in the printer's character attribute tables now.
196 ;; If Genesis could write constant arrays into a target core,
197 ;; that would be nice, and would tidy up some other things too.
198 (show-and-call !printer-cold-init
)
200 (progn (prin1 `(package = ,(package-name *package
*)))
203 ;; *RAW-SLOT-DATA* is essentially a compile-time constant
204 ;; but isn't dumpable as such because it has functions in it.
205 (show-and-call sb
!kernel
::!raw-slot-data-init
)
207 ;; Anyone might call RANDOM to initialize a hash value or something;
208 ;; and there's nothing which needs to be initialized in order for
209 ;; this to be initialized, so we initialize it right away.
210 (show-and-call !random-cold-init
)
212 ;; Must be done before any non-opencoded array references are made.
213 (show-and-call !hairy-data-vector-reffer-init
)
215 (show-and-call !character-database-cold-init
)
216 (show-and-call !character-name-database-cold-init
)
217 (show-and-call sb
!unicode
::!unicode-properties-cold-init
)
219 ;; All sorts of things need INFO and/or (SETF INFO).
220 (/show0
"about to SHOW-AND-CALL !GLOBALDB-COLD-INIT")
221 (show-and-call !globaldb-cold-init
)
223 ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so
224 ;; the basic type machinery needs to be initialized before toplevel
226 (show-and-call !type-class-cold-init
)
227 (!with-init-wrappers
(show-and-call sb
!kernel
::!primordial-type-cold-init
))
228 (show-and-call !world-lock-cold-init
)
229 (show-and-call !classes-cold-init
)
230 (show-and-call !early-type-cold-init
)
231 (show-and-call !late-type-cold-init
)
232 (show-and-call !alien-type-cold-init
)
233 (show-and-call !target-type-cold-init
)
234 ;; FIXME: It would be tidy to make sure that that these cold init
235 ;; functions are called in the same relative order as the toplevel
236 ;; forms of the corresponding source files.
238 (show-and-call !policy-cold-init-or-resanify
)
239 (/show0
"back from !POLICY-COLD-INIT-OR-RESANIFY")
241 ;; Must be done before toplevel forms are invoked
242 ;; because a toplevel defstruct will need to add itself
243 ;; to the subclasses of STRUCTURE-OBJECT.
244 (show-and-call sb
!kernel
::!set-up-structure-object-class
)
246 (dolist (x *!cold-defconstants
*)
247 (destructuring-bind (name source-loc
&optional docstring
) x
248 (setf (info :variable
:kind name
) :constant
)
249 (when source-loc
(setf (info :source-location
:constant name
) source-loc
))
250 (when docstring
(setf (fdocumentation name
'variable
) docstring
))))
252 (dolist (x *!cold-defuns
*)
253 (destructuring-bind (name . inline-expansion
) x
254 (%defun
name (fdefinition name
) nil inline-expansion
))))
256 ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
257 ;; fixups be done separately? Wouldn't that be clearer and better?
259 (/show0
"doing cold toplevel forms and fixups")
261 (progn (write `("Length(TLFs)= " ,(length *!cold-toplevels
*)))
265 (loop for index-in-cold-toplevels from
0
266 for toplevel-thing in
(prog1 *!cold-toplevels
*
267 (makunbound '*!cold-toplevels
*))
270 (when (zerop (mod index-in-cold-toplevels
1024))
271 (/show0
"INDEX-IN-COLD-TOPLEVELS=..")
272 (/hexstr index-in-cold-toplevels
))
273 (typecase toplevel-thing
275 (funcall toplevel-thing
))
276 ((cons (eql :load-time-value
))
277 (setf (svref *!load-time-values
* (third toplevel-thing
))
278 (funcall (second toplevel-thing
))))
279 ((cons (eql :load-time-value-fixup
))
280 (setf (sap-ref-word (int-sap (get-lisp-obj-address (second toplevel-thing
)))
281 (third toplevel-thing
))
282 (get-lisp-obj-address
283 (svref *!load-time-values
* (fourth toplevel-thing
)))))
284 ((cons (eql defstruct
))
285 (apply 'sb
!kernel
::%defstruct
(cdr toplevel-thing
)))
287 (!cold-lose
"bogus operation in *!COLD-TOPLEVELS*")))))
288 (/show0
"done with loop over cold toplevel forms and fixups")
290 (show-and-call time-reinit
)
292 ;; Set sane values again, so that the user sees sane values instead
293 ;; of whatever is left over from the last DECLAIM/PROCLAIM.
294 (show-and-call !policy-cold-init-or-resanify
)
296 ;; Only do this after toplevel forms have run, 'cause that's where
298 (setf *type-system-initialized
* t
)
300 ;; now that the type system is definitely initialized, fixup UNKNOWN
301 ;; types that have crept in.
302 (show-and-call !fixup-type-cold-init
)
303 ;; run the PROCLAIMs.
304 (show-and-call !late-proclaim-cold-init
)
306 (show-and-call os-cold-init-or-reinit
)
307 (show-and-call !pathname-cold-init
)
308 (show-and-call !debug-info-cold-init
)
310 (show-and-call stream-cold-init-or-reset
)
311 (show-and-call !loader-cold-init
)
312 (show-and-call !foreign-cold-init
)
313 #!-
(and win32
(not sb-thread
))
314 (show-and-call signal-cold-init-or-reinit
)
316 (show-and-call float-cold-init-or-reinit
)
318 (show-and-call !class-finalize
)
320 ;; The reader and printer are initialized very late, so that they
321 ;; can do hairy things like invoking the compiler as part of their
323 (let ((*readtable
* (make-readtable)))
324 (show-and-call !reader-cold-init
)
325 (show-and-call !sharpm-cold-init
)
326 (show-and-call !backq-cold-init
)
327 ;; The *STANDARD-READTABLE* is assigned at last because the above
328 ;; functions would operate on the standard readtable otherwise---
329 ;; which would result in an error.
330 (setf *standard-readtable
* *readtable
*))
331 (setf *readtable
* (copy-readtable *standard-readtable
*))
332 (setf sb
!debug
:*debug-readtable
* (copy-readtable *standard-readtable
*))
333 (sb!pretty
:!pprint-cold-init
)
334 (setq *print-level
* nil
*print-length
* nil
) ; restore defaults
336 ;; the ANSI-specified initial value of *PACKAGE*
337 (setf *package
* (find-package "COMMON-LISP-USER"))
339 ;; Enable normal (post-cold-init) behavior of INFINITE-ERROR-PROTECT.
340 (setf sb
!kernel
::*maximum-error-depth
* 10)
341 (/show0
"enabling internal errors")
342 (setf (extern-alien "internal_errors_enabled" int
) 1)
345 ; hppa heap is segmented, lisp and c uses a stub to call eachother
346 #!+hpux
(%primitive sb
!vm
::setup-return-from-lisp-stub
)
347 ;; The system is finally ready for GC.
348 (/show0
"enabling GC")
349 (setq *gc-inhibit
* nil
)
350 (/show0
"doing first GC")
352 (/show0
"back from first GC")
356 (/show0
"going into toplevel loop")
357 (handling-end-of-the-world
359 (critically-unreachable "after TOPLEVEL-INIT")))
361 (define-deprecated-function :early
"1.0.56.55" quit
(exit sb
!thread
:abort-thread
)
362 (&key recklessly-p
(unix-status 0))
363 (if (or recklessly-p
(sb!thread
:main-thread-p
))
364 (exit :code unix-status
:abort recklessly-p
)
365 (sb!thread
:abort-thread
))
366 (critically-unreachable "after trying to die in QUIT"))
368 (declaim (ftype (sfunction (&key
(:code
(or null exit-code
))
369 (:timeout
(or null real
))
373 (defun exit (&key code abort
(timeout *exit-timeout
*))
375 "Terminates the process, causing SBCL to exit with CODE. CODE
376 defaults to 0 when ABORT is false, and 1 when it is true.
378 When ABORT is false (the default), current thread is first unwound,
379 *EXIT-HOOKS* are run, other threads are terminated, and standard
380 output streams are flushed before SBCL calls exit(3) -- at which point
381 atexit(3) functions will run. If multiple threads call EXIT with ABORT
382 being false, the first one to call it will complete the protocol.
384 When ABORT is true, SBCL exits immediately by calling _exit(2) without
385 unwinding stack, or calling exit hooks. Note that _exit(2) does not
386 call atexit(3) functions unlike exit(3).
388 Recursive calls to EXIT cause EXIT to behave as it ABORT was true.
390 TIMEOUT controls waiting for other threads to terminate when ABORT is
391 NIL. Once current thread has been unwound and *EXIT-HOOKS* have been
392 run, spawning new threads is prevented and all other threads are
393 terminated by calling TERMINATE-THREAD on them. The system then waits
394 for them to finish using JOIN-THREAD, waiting at most a total TIMEOUT
395 seconds for all threads to join. Those threads that do not finish
396 in time are simply ignored while the exit protocol continues. TIMEOUT
397 defaults to *EXIT-TIMEOUT*, which in turn defaults to 60. TIMEOUT NIL
398 means to wait indefinitely.
400 Note that TIMEOUT applies only to JOIN-THREAD, not *EXIT-HOOKS*. Since
401 TERMINATE-THREAD is asynchronous, getting multithreaded application
402 termination with complex cleanups right using it can be tricky. To
403 perform an orderly synchronous shutdown use an exit hook instead of
404 relying on implicit thread termination.
406 Consequences are unspecified if serious conditions occur during EXIT
407 excepting errors from *EXIT-HOOKS*, which cause warnings and stop
408 execution of the hook that signaled, but otherwise allow the exit
409 process to continue normally."
410 (if (or abort
*exit-in-process
*)
411 (os-exit (or code
1) :abort t
)
412 (let ((code (or code
0)))
413 (with-deadline (:seconds nil
:override t
)
414 (sb!thread
:grab-mutex
*exit-lock
*))
415 (setf *exit-in-process
* code
416 *exit-timeout
* timeout
)
417 (throw '%end-of-the-world t
)))
418 (critically-unreachable "After trying to die in EXIT."))
420 ;;;; initialization functions
422 (defun thread-init-or-reinit ()
423 (sb!thread
::init-initial-thread
)
424 (sb!thread
::init-job-control
)
425 (sb!thread
::get-foreground
))
429 (setf sb
!win32
::*ansi-codepage
* nil
)
430 (setf *default-external-format
* nil
)
431 (setf sb
!alien
::*default-c-string-external-format
* nil
)
432 ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
434 ;; Initialize streams first, so that any errors can be printed later
436 (os-cold-init-or-reinit)
437 (thread-init-or-reinit)
438 #!-
(and win32
(not sb-thread
))
439 (signal-cold-init-or-reinit)
440 (setf (extern-alien "internal_errors_enabled" int
) 1)
441 (float-cold-init-or-reinit))
445 ;; If the debugger was disabled in the saved core, we need to
446 ;; re-disable ldb again.
447 (when (eq *invoke-debugger-hook
* 'sb
!debug
::debugger-disabled-hook
)
448 (sb!debug
::disable-debugger
))
449 (call-hooks "initialization" *init-hooks
*))
451 ;;;; some support for any hapless wretches who end up debugging cold
454 ;;; Decode THING into hexadecimal notation using only machinery
455 ;;; available early in cold init.
457 (defun hexstr (thing)
458 (/noshow0
"entering HEXSTR")
459 (let* ((addr (get-lisp-obj-address thing
))
460 (nchars (* sb
!vm
:n-word-bytes
2))
461 (str (make-string (+ nchars
2) :element-type
'base-char
)))
462 (/noshow0
"ADDR and STR calculated")
463 (setf (char str
0) #\
0
465 (/noshow0
"CHARs 0 and 1 set")
467 (/noshow0
"at head of DOTIMES loop")
468 (let* ((nibble (ldb (byte 4 0) addr
))
469 (chr (char "0123456789abcdef" nibble
)))
470 (declare (type (unsigned-byte 4) nibble
)
472 (/noshow0
"NIBBLE and CHR calculated")
473 (setf (char str
(- (1+ nchars
) i
)) chr
474 addr
(ash addr -
4))))
477 ;; But: you almost never need this. Just use WRITE in all its glory.
479 (defun cold-print (x)
480 (labels ((%cold-print
(obj depthoid
)
482 (%primitive print
"...")
485 (%primitive print obj
))
487 (%primitive print
(symbol-name obj
)))
489 (%primitive print
"cons:")
490 (let ((d (1+ depthoid
)))
491 (%cold-print
(car obj
) d
)
492 (%cold-print
(cdr obj
) d
)))
494 (%primitive print
(hexstr obj
)))))))
498 (in-package "SB!INT")
499 (defun unintern-init-only-stuff ()
500 (let ((this-package (find-package "SB-INT")))
501 ;; For some reason uninterning these:
502 ;; DEF!TYPE DEF!CONSTANT DEF!STRUCT
503 ;; does not work, they stick around as uninterned symbols.
504 ;; Some other macros must expand into them. Ugh.
505 (dolist (s '(defenum defun-cached with-globaldb-name
508 #!-sb-show
(/hexstr
/nohexstr
/noshow
/noshow0
/noxhow
509 /primitive-print
/show
/show0
/xhow
)))
510 (unintern s this-package
))))