"!DEF-BOOLEAN-ATTRIBUTE"
"WITH-REBOUND-IO-SYNTAX"
"WITH-SANE-IO-SYNTAX"
+ "WITH-PROGRESSIVE-TIMEOUT"
;; ..and CONDITIONs..
"BUG"
(critically-unreachable "after trying to die in QUIT"))
(declaim (ftype (sfunction (&key (:code (or null exit-code))
- (:timeout (or null real))
+ (:timeout (or null real))
(:abort t))
nil)
exit))
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 with the specified TIMEOUT. If a
-thread does not finish in TIMEOUT seconds, it is left to its own
-devices while the exit protocol continues. TIMEOUT defaults to
-*EXIT-TIMEOUT*, which in turn defaults to 60.
+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
(go :restart)))))))
(defmacro wait-for (test-form &key timeout)
+ #!+sb-doc
"Wait until TEST-FORM evaluates to true, then return its primary value.
If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
returning NIL.
Experimental: subject to change without prior notice."
`(dx-flet ((wait-for-test () (progn ,test-form)))
(%wait-for #'wait-for-test ,timeout)))
+
+(defmacro with-progressive-timeout ((name &key seconds)
+ &body body)
+ #!+sb-doc
+ "Binds NAME as a local function for BODY. Each time #'NAME is called, it
+returns SECONDS minus the time that has elapsed since BODY was entered, or
+zero if more time than SECONDS has elapsed. If SECONDS is NIL, #'NAME
+returns NIL each time."
+ (with-unique-names (deadline time-left sec)
+ `(let* ((,sec ,seconds)
+ (,deadline
+ (when ,sec
+ (+ (get-internal-real-time)
+ (round (* ,seconds internal-time-units-per-second))))))
+ (flet ((,name ()
+ (when ,deadline
+ (let ((,time-left (- ,deadline (get-internal-real-time))))
+ (if (plusp ,time-left)
+ (* (coerce ,time-left 'single-float)
+ ,(/ 1.0 internal-time-units-per-second))
+ 0)))))
+ ,@body))))
(defun handle-thread-exit (thread)
(/show0 "HANDLING THREAD EXIT")
(when *exit-in-process*
- (if (consp *exit-in-process*)
- ;; This means we're the main thread, but someone else
- ;; requested the exit and exiting with the right code is the
- ;; only thing left to do.
- (os-exit (car *exit-in-process*) :abort nil)
- (%exit)))
+ (%exit))
;; Lisp-side cleanup
(with-all-threads-lock
(setf (thread-%alive-p thread) nil)
(grab-mutex *make-thread-lock*)
(let ((timeout sb!ext:*exit-timeout*)
(code *exit-in-process*)
+ (current *current-thread*)
(joinees nil)
(main nil))
(dolist (thread (list-all-threads))
- (cond ((eq thread *current-thread*))
+ (cond ((eq thread current))
((main-thread-p thread)
(setf main thread))
(t
(terminate-thread thread)
(push thread joinees))
(interrupt-thread-error ())))))
- (dolist (thread (nreverse joinees))
- (join-thread thread :default t :timeout timeout))
- ;; Need to defer till others have joined, because when main
- ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would
- ;; get the exit code wrong.
- (when main
- (handler-case
- (interrupt-thread
- main
- (lambda ()
- (setf *exit-in-process* (list code))
- (throw 'sb!impl::%end-of-the-world t)))
- (interrupt-thread-error ()))
- ;; Normally this never finishes, as once the main-thread
- ;; unwinds we exit with the right code, but if times out
- ;; before that happens, we will exit after returning.
- (join-thread main :default t :timeout timeout)))))
+ (with-progressive-timeout (time-left :seconds timeout)
+ (dolist (thread joinees)
+ (join-thread thread :default t :timeout (time-left)))
+ ;; Need to defer till others have joined, because when main
+ ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would
+ ;; get the exit code wrong.
+ (when main
+ (handler-case
+ (interrupt-thread
+ main
+ (lambda ()
+ (setf *exit-in-process* (list code))
+ (throw 'sb!impl::%end-of-the-world t)))
+ (interrupt-thread-error ()))
+ ;; Normally this never finishes, as once the main-thread unwinds we
+ ;; exit with the right code, but if times out before that happens,
+ ;; we will exit after returning -- or rathe racing the main thread
+ ;; to calling OS-EXIT.
+ (join-thread main :default t :timeout (time-left)))))))
(defun terminate-session ()
#!+sb-doc
(defun %exit ()
;; If anything goes wrong, we will exit immediately and forcibly.
(handler-bind ((serious-condition *exit-error-handler*))
- (let (ok)
- (unwind-protect
- (progn
- (flush-standard-output-streams)
- (sb!thread::%exit-other-threads)
- (setf ok t))
- (os-exit *exit-in-process* :abort (not ok))))))
+ (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)))))))
\f
;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
projects / sbcl.git / commitdiff