X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=9632d08678d6bcbc4cfa5f08e854f97571b08d30;hb=829ced3e78a23ba153ba4db64e6ea6984c2313b6;hp=73849728e70bdb13c4cef2832bc9e84e06f98732;hpb=a24e6c6610b7e7d35b4509a1fce670566d3195bf;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 7384972..9632d08 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -30,6 +30,7 @@ *allow-with-interrupts* *interrupts-enabled* *interrupt-pending* + #!+sb-thruption *thruption-pending* *type-system-initialized*)) (defvar *cold-init-complete-p*) @@ -75,29 +76,50 @@ been specified on the command-line.") ;;; by QUIT) is caught and any final processing and return codes are ;;; handled appropriately. (defmacro handling-end-of-the-world (&body body) - (with-unique-names (caught) - `(without-interrupts - (let ((,caught - (catch '%end-of-the-world - (unwind-protect - (with-local-interrupts ,@body (quit)) - (handler-case - (with-local-interrupts - (call-hooks "exit" *exit-hooks* :on-error :warn)) - (serious-condition () - 1)))))) - ;; If user called QUIT and exit hooks were OK, the status is what it - ;; is -- even eg. streams cannot be flushed anymore. Even if - ;; something goes wrong now, we still report what was asked. We still - ;; want to have %END-OF-THE-WORLD visible, though. - (catch '%end-of-the-world - (handler-case - (unwind-protect - (progn - (flush-standard-output-streams) - (sb!thread::terminate-session)) - (sb!unix:unix-exit ,caught)) - (serious-condition ()))))))) + `(without-interrupts + (catch '%end-of-the-world + (unwind-protect + (with-local-interrupts + (unwind-protect + (progn ,@body) + (call-exit-hooks))) + (%exit))))) + +(defvar *exit-lock*) +(defvar *exit-in-process* nil) +(declaim (type (or null real) *exit-timeout*)) +(defvar *exit-timeout* 60 + "Default amount of seconds, if any, EXIT should wait for other +threads to finish after terminating them. Default value is 60. NIL +means to wait indefinitely.") + +(defun os-exit-handler (condition) + (declare (ignore condition)) + (os-exit *exit-in-process* :abort t)) + +(defvar *exit-error-handler* #'os-exit-handler) + +(defun call-exit-hooks () + (unless *exit-in-process* + (setf *exit-in-process* 0)) + (handler-bind ((serious-condition *exit-error-handler*)) + (call-hooks "exit" *exit-hooks* :on-error :warn))) + +(defun %exit () + ;; If anything goes wrong, we will exit immediately and forcibly. + (handler-bind ((serious-condition *exit-error-handler*)) + (let ((ok nil) + (code *exit-in-process*)) + (if (consp code) + ;; Another thread called EXIT, and passed the buck to us -- only + ;; final call left to do. + (os-exit (car code) :abort nil) + (unwind-protect + (progn + (flush-standard-output-streams) + (sb!thread::%exit-other-threads) + (setf ok t)) + (os-exit code :abort (not ok))))))) ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* @@ -109,7 +131,7 @@ been specified on the command-line.") (let ((*current-error-depth* (1+ *current-error-depth*))) (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth") ;; arbitrary truncation - #!+sb-show (sb!debug:backtrace 8) + #!+sb-show (sb!debug:print-backtrace :count 8) ,@forms))) ;;; a helper function for INFINITE-ERROR-PROTECT @@ -176,11 +198,12 @@ any non-negative real number." (when (or (not (realp seconds)) (minusp seconds)) (error 'simple-type-error - :format-control "invalid argument to SLEEP: ~S" + :format-control "Invalid argument to SLEEP: ~S, ~ + should be a non-negative real." :format-arguments (list seconds) :datum seconds :expected-type '(real 0))) - #!-win32 + #!-(and win32 (not sb-thread)) (multiple-value-bind (sec nsec) (if (integerp seconds) (values seconds 0) @@ -194,7 +217,7 @@ any non-negative real number." do (decf sec (expt 10 8)) (sb!unix:nanosleep (expt 10 8) 0)) (sb!unix:nanosleep sec nsec)) - #!+win32 + #!+(and win32 (not sb-thread)) (sb!win32:millisleep (truncate (* seconds 1000))) nil) @@ -315,7 +338,7 @@ any non-negative real number." value) (load (native-pathname value)))) (:quit - (quit)))) + (exit)))) (flush-standard-output-streams))) (with-simple-restart (abort "Skip rest of --eval and --load options.") (dolist (option options) @@ -330,7 +353,7 @@ any non-negative real number." ;; Shell-style. (when (member (stream-error-stream e) (list *stdout* *stdin* *stderr*)) - (quit))))) + (exit))))) ;; Let's not use the *TTY* for scripts, ok? Also, normally we use ;; synonym streams, but in order to have the broken pipe/eof error ;; handling right we want to bind them for scripts. @@ -347,7 +370,7 @@ any non-negative real number." (sb!fasl::maybe-skip-shebang-line f) (load-script f)))))) -;; Errors while processing the command line cause the system to QUIT, +;; Errors while processing the command line cause the system to EXIT, ;; instead of trying to go into the Lisp debugger, because trying to ;; go into the Lisp debugger would get into various annoying issues of ;; where we should go after the user tries to return from the @@ -357,7 +380,7 @@ any non-negative real number." "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%" control-string args) - (quit :unix-status 1)) + (exit :code 1)) ;;; the default system top level function (defun toplevel-init () @@ -474,7 +497,8 @@ any non-negative real number." ;; Delete all the options that we processed, so that only ;; user-level options are left visible to user code. - (setf (rest *posix-argv*) options) + (when *posix-argv* + (setf (rest *posix-argv*) options)) ;; Disable debugger before processing initialization files & co. (when disable-debugger @@ -519,11 +543,11 @@ any non-negative real number." s)) (/show0 "CONTINUEing from pre-REPL RESTART-CASE") (values)) ; (no-op, just fall through) - (quit () - :report "Quit SBCL (calling #'QUIT, killing the process)." + (exit () + :report "Exit SBCL (calling #'EXIT, killing the process)." :test (lambda (c) (declare (ignore c)) (not script)) - (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") - (quit :unix-status 1)))) + (/show0 "falling through to EXIT from pre-REPL RESTART-CASE") + (exit :code 1)))) ;; one more time for good measure, in case we fell out of the ;; RESTART-CASE above before one of the flushes in the ordinary @@ -600,7 +624,7 @@ that provides the REPL for the system. Assumes that *STANDARD-INPUT* and (let* ((eof-marker (cons nil nil)) (form (read in nil eof-marker))) (if (eq form eof-marker) - (quit) + (exit) form))) (defun repl-fun (noprint)