- (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)))))))