;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
;; be explicitly set in order to be meaningful.
(setf *after-gc-hooks* nil
+ *in-without-gcing* nil
*gc-inhibit* t
*gc-pending* nil
#!+sb-thread *stop-for-gc-pending* #!+sb-thread nil
- sb!unix::*interrupts-enabled* t
- sb!unix::*interrupt-pending* nil
+ *allow-with-interrupts* t
+ sb!unix::*unblock-deferrables-on-enabling-interrupts-p* nil
+ *interrupts-enabled* t
+ *interrupt-pending* nil
+ #!+sb-thruption #!+sb-thruption *thruption-pending* nil
*break-on-signals* nil
*maximum-error-depth* 10
*current-error-depth* 0
*cold-init-complete-p* nil
- *type-system-initialized* nil)
+ *type-system-initialized* nil
+ sb!vm:*alloc-signal* nil
+ sb!kernel::*gc-epoch* (cons nil nil))
+ ;; I'm not sure where eval is first called, so I put this first.
+ (show-and-call !eval-cold-init)
+ (show-and-call !deadline-cold-init)
(show-and-call thread-init-or-reinit)
(show-and-call !typecheckfuns-cold-init)
;; this to be initialized, so we initialize it right away.
(show-and-call !random-cold-init)
+ ;; Must be done before any non-opencoded array references are made.
+ (show-and-call !hairy-data-vector-reffer-init)
+
(show-and-call !character-database-cold-init)
+ (show-and-call !character-name-database-cold-init)
(show-and-call !early-package-cold-init)
(show-and-call !package-cold-init)
;; forms run.
(show-and-call !type-class-cold-init)
(show-and-call !typedefs-cold-init)
+ (show-and-call !world-lock-cold-init)
(show-and-call !classes-cold-init)
(show-and-call !early-type-cold-init)
(show-and-call !late-type-cold-init)
(show-and-call !policy-cold-init-or-resanify)
(/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY")
+ (show-and-call !constantp-cold-init)
(show-and-call !early-proclaim-cold-init)
;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
(setf (svref *!load-time-values* (third toplevel-thing))
(funcall (second toplevel-thing))))
(:load-time-value-fixup
- (setf (sap-ref-word (second toplevel-thing) 0)
+ (setf (sap-ref-word (int-sap (get-lisp-obj-address (second toplevel-thing)))
+ (third toplevel-thing))
(get-lisp-obj-address
- (svref *!load-time-values* (third toplevel-thing)))))
- #!+(and (or x86 x86-64) gencgc)
- (:load-time-code-fixup
- (sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
- (third toplevel-thing)
- (fourth toplevel-thing)
- (fifth toplevel-thing)))
+ (svref *!load-time-values* (fourth toplevel-thing)))))
(t
(!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
(t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
(show-and-call !late-proclaim-cold-init)
(show-and-call os-cold-init-or-reinit)
+ (show-and-call !pathname-cold-init)
+ (show-and-call !debug-info-cold-init)
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
(show-and-call !foreign-cold-init)
- #!-win32 (show-and-call signal-cold-init-or-reinit)
+ #!-(and win32 (not sb-thread))
+ (show-and-call signal-cold-init-or-reinit)
(/show0 "enabling internal errors")
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
- ;; FIXME: This list of modes should be defined in one place and
- ;; explicitly shared between here and REINIT.
-
- ;; FIXME: For some unknown reason, NetBSD/x86 won't run with the
- ;; :invalid trap enabled. That should be fixed, but not today...
- ;; PEM -- April 5, 2004
- (set-floating-point-modes
- :traps '(:overflow #!-netbsd :invalid :divide-by-zero))
+ (show-and-call float-cold-init-or-reinit)
(show-and-call !class-finalize)
;; The reader and printer are initialized very late, so that they
;; can do hairy things like invoking the compiler as part of their
;; initialization.
- (show-and-call !reader-cold-init)
- (let ((*readtable* *standard-readtable*))
+ (let ((*readtable* (make-readtable)))
+ (show-and-call !reader-cold-init)
(show-and-call !sharpm-cold-init)
- (show-and-call !backq-cold-init))
+ (show-and-call !backq-cold-init)
+ ;; The *STANDARD-READTABLE* is assigned at last because the above
+ ;; functions would operate on the standard readtable otherwise---
+ ;; which would result in an error.
+ (setf *standard-readtable* *readtable*))
(setf *readtable* (copy-readtable *standard-readtable*))
(setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
(sb!pretty:!pprint-cold-init)
(/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
(setf *cold-init-complete-p* t)
+ ; hppa heap is segmented, lisp and c uses a stub to call eachother
+ #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
;; The system is finally ready for GC.
(/show0 "enabling GC")
- (gc-on)
+ (setq *gc-inhibit* nil)
(/show0 "doing first GC")
(gc :full t)
(/show0 "back from first GC")
(toplevel-init)
(critically-unreachable "after TOPLEVEL-INIT")))
-(defun quit (&key recklessly-p (unix-status 0))
- #!+sb-doc
- "Terminate the current Lisp. Things are cleaned up (with
-UNWIND-PROTECT and so forth) unless RECKLESSLY-P is non-NIL. On
-UNIX-like systems, UNIX-STATUS is used as the status code."
- (declare (type (signed-byte 32) unix-status))
- (/show0 "entering QUIT")
- (if recklessly-p
- (sb!unix:unix-exit unix-status)
- (throw '%end-of-the-world unix-status))
+(define-deprecated-function :early "1.0.56.55" quit (exit sb!thread:abort-thread)
+ (&key recklessly-p (unix-status 0))
+ (if (or recklessly-p (sb!thread:main-thread-p))
+ (exit :code unix-status :abort recklessly-p)
+ (sb!thread:abort-thread))
(critically-unreachable "after trying to die in QUIT"))
+
+(declaim (ftype (sfunction (&key (:code (or null exit-code))
+ (:timeout (or null real))
+ (:abort t))
+ nil)
+ exit))
+(defun exit (&key code abort (timeout *exit-timeout*))
+ #!+sb-doc
+ "Terminates the process, causing SBCL to exit with CODE. CODE
+defaults to 0 when ABORT is false, and 1 when it is true.
+
+When ABORT is false (the default), current thread is first unwound,
+*EXIT-HOOKS* are run, other threads are terminated, and standard
+output streams are flushed before SBCL calls exit(3) -- at which point
+atexit(3) functions will run. If multiple threads call EXIT with ABORT
+being false, the first one to call it will complete the protocol.
+
+When ABORT is true, SBCL exits immediately by calling _exit(2) without
+unwinding stack, or calling exit hooks. Note that _exit(2) does not
+call atexit(3) functions unlike exit(3).
+
+Recursive calls to EXIT cause EXIT to behave as it ABORT was true.
+
+TIMEOUT controls waiting for other threads to terminate when ABORT is
+NIL. Once current thread has been unwound and *EXIT-HOOKS* have been
+run, spawning new threads is prevented and all other threads are
+terminated by calling TERMINATE-THREAD on them. The system then waits
+for them to finish using JOIN-THREAD, waiting at most a total TIMEOUT
+seconds for all threads to join. Those threads that do not finish
+in time are simply ignored while the exit protocol continues. TIMEOUT
+defaults to *EXIT-TIMEOUT*, which in turn defaults to 60. TIMEOUT NIL
+means to wait indefinitely.
+
+Note that TIMEOUT applies only to JOIN-THREAD, not *EXIT-HOOKS*. Since
+TERMINATE-THREAD is asynchronous, getting multithreaded application
+termination with complex cleanups right using it can be tricky. To
+perform an orderly synchronous shutdown use an exit hook instead of
+relying on implicit thread termination.
+
+Consequences are unspecified if serious conditions occur during EXIT
+excepting errors from *EXIT-HOOKS*, which cause warnings and stop
+execution of the hook that signaled, but otherwise allow the exit
+process to continue normally."
+ (if (or abort *exit-in-process*)
+ (os-exit (or code 1) :abort t)
+ (let ((code (or code 0)))
+ (with-deadline (:seconds nil :override t)
+ (sb!thread:grab-mutex *exit-lock*))
+ (setf *exit-in-process* code
+ *exit-timeout* timeout)
+ (throw '%end-of-the-world t)))
+ (critically-unreachable "After trying to die in EXIT."))
\f
;;;; initialization functions
(sb!thread::get-foreground))
(defun reinit ()
+ #!+win32
+ (setf sb!win32::*ansi-codepage* nil)
(setf *default-external-format* nil)
- (without-interrupts
- (without-gcing
- (os-cold-init-or-reinit)
- (thread-init-or-reinit)
- (stream-reinit)
- #!-win32 (signal-cold-init-or-reinit)
- (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
- ;; PRINT seems not to like x86 NPX denormal floats like
- ;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are
- ;; disabled by default. Joe User can explicitly enable them if
- ;; desired.
- ;;
- ;; see also comment at the previous SET-FLOATING-POINT-MODES
- ;; call site.
- (set-floating-point-modes
- :traps '(:overflow #!-netbsd :invalid :divide-by-zero))))
+ (setf sb!alien::*default-c-string-external-format* nil)
+ ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
+ (without-gcing
+ ;; Initialize streams first, so that any errors can be printed later
+ (stream-reinit t)
+ (os-cold-init-or-reinit)
+ (thread-init-or-reinit)
+ #!-(and win32 (not sb-thread))
+ (signal-cold-init-or-reinit)
+ (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
+ (float-cold-init-or-reinit))
(gc-reinit)
- ;; make sure TIME works correctly from saved cores
- (setf *internal-real-time-base-seconds* nil)
(foreign-reinit)
- (dolist (hook *init-hooks*)
- (with-simple-restart (continue "Skip this initialization hook.")
- (funcall hook))))
+ (time-reinit)
+ ;; If the debugger was disabled in the saved core, we need to
+ ;; re-disable ldb again.
+ (when (eq *invoke-debugger-hook* 'sb!debug::debugger-disabled-hook)
+ (sb!debug::disable-debugger))
+ (call-hooks "initialization" *init-hooks*))
\f
;;;; some support for any hapless wretches who end up debugging cold
;;;; init code
#!+sb-show
(defun hexstr (thing)
(/noshow0 "entering HEXSTR")
- (let ((addr (get-lisp-obj-address thing))
- (str (make-string 10 :element-type 'base-char)))
+ (let* ((addr (get-lisp-obj-address thing))
+ (nchars (* sb!vm:n-word-bytes 2))
+ (str (make-string (+ nchars 2) :element-type 'base-char)))
(/noshow0 "ADDR and STR calculated")
(setf (char str 0) #\0
(char str 1) #\x)
(/noshow0 "CHARs 0 and 1 set")
- (dotimes (i 8)
+ (dotimes (i nchars)
(/noshow0 "at head of DOTIMES loop")
(let* ((nibble (ldb (byte 4 0) addr))
(chr (char "0123456789abcdef" nibble)))
(declare (type (unsigned-byte 4) nibble)
(base-char chr))
(/noshow0 "NIBBLE and CHR calculated")
- (setf (char str (- 9 i)) chr
+ (setf (char str (- (1+ nchars) i)) chr
addr (ash addr -4))))
str))
#!+sb-show
(defun cold-print (x)
- (typecase x
- (simple-string (sb!sys:%primitive print x))
- (symbol (sb!sys:%primitive print (symbol-name x)))
- (list (let ((count 0))
- (sb!sys:%primitive print "list:")
- (dolist (i x)
- (when (>= (incf count) 4)
- (sb!sys:%primitive print "...")
- (return))
- (cold-print i))))
- (t (sb!sys:%primitive print (hexstr x)))))
+ (labels ((%cold-print (obj depthoid)
+ (if (> depthoid 4)
+ (sb!sys:%primitive print "...")
+ (typecase obj
+ (simple-string
+ (sb!sys:%primitive print obj))
+ (symbol
+ (sb!sys:%primitive print (symbol-name obj)))
+ (cons
+ (sb!sys:%primitive print "cons:")
+ (let ((d (1+ depthoid)))
+ (%cold-print (car obj) d)
+ (%cold-print (cdr obj) d)))
+ (t
+ (sb!sys:%primitive print (hexstr obj)))))))
+ (%cold-print x 0))
+ (values))
projects / sbcl.git / blobdiff