From: Nikodemus Siivola Date: Tue, 6 Dec 2011 11:44:06 +0000 (+0200) Subject: redesign exiting SBCL X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0;p=sbcl.git redesign exiting SBCL Deprecate QUIT. It occupies an uncomfortable niche between processes and threads, and doesn't actually do what it says on the tin unless you call it from the main thread. SIGTERM now uses EXIT, and doesn't depend on sessions. WITH-DEADLINE (:SECONDS NIL :OVERRIDE T) can now be used to ignore deadlines. JOIN-THREAD on the main thread now blocks indefinitely instead of claiming the thread did not exit normally. New functions: * SB-EXT:EXIT. Always exits the process. Takes keywords :CODE, :ABORT, and :TIMEOUT. Code is the exit status. Abort controls if the exit is clean (unwind, exit-hooks, terminate other threads) or dirty. Timeout controls how long to wait for other threads to finish. * SB-THREAD:RETURN-FROM-THREAD. Normal termination for current thread -- equivalent to return from the thread function with the specified values. Takes keyword :ALLOW-EXIT, which determines if returning from the main thread is an error, or equivalent to calling EXIT :CODE 0. * SB-THREAD:ABORT-THREAD. Abnormal termination for current thread -- equivalent to invoking the initial ABORT restart estabilished by MAKE-THREAD (previously known as TERMINATE-THREAD, but ANSI recommends there to always be an ABORT restart.) Takes keyword :ALLOW-EXIT, which determines if aborting the main thread is an error, or equivalent to calling EXIT :CODE 1. * SB-THREAD:MAIN-THREAD-P. Let's you determine if a given thread is the main thread of the process. This is important for some functions on some operating systems -- and RETURN-FROM-THREAD and ABORT-THREAD also need it. * SB-THREAD:MAIN-THREAD. Returns the main thread object. Convenient for when you need to eg. load a foreign library in the main thread. --- diff --git a/NEWS b/NEWS index 897c552..86d8250 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.56: + * enhancement: redesigned protocol for quitting SBCL. SB-EXT:EXIT is the new + main entry point, SB-EXT:QUIT is deprecated. + * enhancement: additions to the SB-THREAD API: RETURN-FROM-THREAD, + ABORT-THREAD, MAIN-THREAD-P, and MAIN-THREAD. * enhancement: FASL loading no longer grabs the world-lock. * enhancement: GENCGC reclaims space more aggressively when objects being allocated are a large fraction of the total available heap space. @@ -37,6 +41,8 @@ changes relative to sbcl-1.0.56: * bug fix: better input error reporting for COMPILE-FILE. (lp#493380) * bug fix: default size of non-nursery generations has been shrunk on GENCGC, allowing faster release of memory back to the OS. (lp#991293) + * bug fix: WITH-DEADLINE (:SECONDS NIL :OVERRIDE T) now drops any + existing deadline for the dynamic scope of its body. * documentation: ** improved docstrings: REPLACE (lp#965592) diff --git a/contrib/asdf-module.mk b/contrib/asdf-module.mk index 873606b..ddce36b 100644 --- a/contrib/asdf-module.mk +++ b/contrib/asdf-module.mk @@ -27,7 +27,7 @@ export CC SBCL EXTRA_CFLAGS EXTRA_LDFLAGS all: $(EXTRA_ALL_TARGETS) $(MAKE) -C ../asdf - $(SBCL) --eval '(defvar *system* "$(SYSTEM)")' --load ../asdf-stub.lisp --eval '(quit)' + $(SBCL) --eval '(defvar *system* "$(SYSTEM)")' --load ../asdf-stub.lisp --eval '(exit)' test: all echo "(asdf:operate (quote asdf:load-op) :$(SYSTEM))" \ diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index db3c251..7997a79 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -328,7 +328,7 @@ (map nil #'sb-thread:destroy-thread threads) (sleep 0.2)) (return-from exit-cmd))))) - (sb-ext:quit :unix-status status) + (sb-ext:exit :code status) (values)) (defun package-cmd (&optional pkg) @@ -783,7 +783,7 @@ ;; command (cond ((eq user-cmd *eof-cmd*) (when *exit-on-eof* - (sb-ext:quit)) + (sb-ext:exit)) (format *output* "EOF~%") t) ((eq user-cmd *null-cmd*) diff --git a/contrib/sb-concurrency/tests/test-gate.lisp b/contrib/sb-concurrency/tests/test-gate.lisp index 9575d3c..64aa864 100644 --- a/contrib/sb-concurrency/tests/test-gate.lisp +++ b/contrib/sb-concurrency/tests/test-gate.lisp @@ -39,7 +39,7 @@ (interrupt-thread (car threads) (lambda () (unwind-protect (when (gate-open-p gate) - (sb-ext:quit)) + (abort-thread)) (open-gate int-gate)))) (wait-on-gate int-gate) (assert (every #'null marks)) diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp index c37bd89..77740e0 100644 --- a/contrib/sb-executable/sb-executable.lisp +++ b/contrib/sb-executable/sb-executable.lisp @@ -32,7 +32,7 @@ strategy." (defvar *exec-header* "#!/bin/sh -- -exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (quit))\" --end-toplevel-options ${1+\"$@\"} +exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (exit))\" --end-toplevel-options ${1+\"$@\"} ") (defun make-executable (output-file fasls diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 13bb23d..c73f2d1 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -461,13 +461,13 @@ (progn (multiple-value-bind (nope error) (ignore-errors (sb-posix:fcntl f sb-posix:f-setlk flock)) - (sb-ext:quit - :unix-status + (sb-ext:exit + :code (cond ((not (null nope)) 1) ((= (sb-posix:syscall-errno error) sb-posix:eagain) 42) (t 86)) - :recklessly-p t #| don't delete the file |#))) + :abort t #| don't delete the file |#))) (progn (setf kid-status (sb-posix:wexitstatus @@ -495,12 +495,12 @@ (pid (sb-posix:fork))) (if (zerop pid) (let ((r (sb-posix:fcntl f sb-posix:f-getlk flock))) - (sb-ext:quit - :unix-status + (sb-ext:exit + :code (cond ((not (zerop r)) 1) ((= (sb-posix:flock-pid flock) ppid) 42) (t 86)) - :recklessly-p t #| don't delete the file |#)) + :abort t #| don't delete the file |#)) (progn (setf kid-status (sb-posix:wexitstatus diff --git a/doc/manual/create-contrib-doc-list.lisp b/doc/manual/create-contrib-doc-list.lisp index 2d4db6b..0518813 100644 --- a/doc/manual/create-contrib-doc-list.lisp +++ b/doc/manual/create-contrib-doc-list.lisp @@ -39,4 +39,4 @@ :name (pathname-name texi-file) :type (pathname-type texi-file))))))) -(sb-ext:quit) +(sb-ext:exit) diff --git a/doc/manual/make-tempfiles.sh b/doc/manual/make-tempfiles.sh index c212d74..aac4bb1 100644 --- a/doc/manual/make-tempfiles.sh +++ b/doc/manual/make-tempfiles.sh @@ -36,7 +36,7 @@ fi SBCL="$SBCLRUNTIME --noinform --no-sysinit --no-userinit --noprint --disable-debugger" # extract version and date -VERSION=`$SBCL --eval '(write-line (lisp-implementation-version))' --eval '(sb-ext:quit)'` +VERSION=`$SBCL --eval '(write-line (lisp-implementation-version))' --eval '(sb-ext:exit)'` MONTH=`date "+%Y-%m"` sed -e "s/@VERSION@/$VERSION/" \ @@ -62,11 +62,11 @@ $SBCL <" + :format-arguments (list values) + :thread self)) + (sb!ext:exit :code 0)) + (t + (throw '%return-from-thread (values-list values)))))) + +(defun abort-thread (&key allow-exit) + "Unwinds from and terminates the current thread abnormally, causing +JOIN-THREAD on current thread to signal an error unless a +default-value is provided. + +If current thread is the main thread of the process (see +MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as +terminating the main thread would terminate the entire process. If +ALLOW-EXIT is true, aborting the main thread is equivalent to calling +SB-EXT:EXIT code 1 and :ABORT NIL. + +Invoking the initial ABORT restart estabilished by MAKE-THREAD is +equivalent to calling ABORT-THREAD in other than main threads. +However, whereas ABORT restart may be rebound, ABORT-THREAD always +unwinds the entire thread. (Behaviour of the initial ABORT restart for +main thread depends on the :TOPLEVEL argument to +SB-EXT:SAVE-LISP-AND-DIE.) + +See also: RETURN-FROM-THREAD and SB-EXT:EXIT." + (let ((self *current-thread*)) + (cond ((main-thread-p self) + (unless allow-exit + (error 'simple-thread-error + :format-control "~@")) + (sb!ext:exit :code 1)) + (t + ;; We /could/ use TOPLEVEL-CATCHER or %END-OF-THE-WORLD as well, but + ;; this seems tidier. Those to are a bit too overloaded already. + (throw '%abort-thread t))))) ;;;; Aliens, low level stuff @@ -1110,6 +1185,13 @@ on this semaphore, then N of them is woken up." #!+sb-thread (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))) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -1118,6 +1200,44 @@ on this semaphore, then N of them is woken up." (when *session* (%delete-thread-from-session thread *session*)))) +(defun %exit-other-threads () + ;; Grabbing this lock prevents new threads from + ;; being spawned, and guarantees that *ALL-THREADS* + ;; is up to date. + (with-deadline (:seconds nil :override t) + (grab-mutex *make-thread-lock*) + (let ((timeout sb!ext:*exit-timeout*) + (code *exit-in-process*) + (joinees nil) + (main nil)) + (dolist (thread (list-all-threads)) + (cond ((eq thread *current-thread*)) + ((main-thread-p thread) + (setf main thread)) + (t + (handler-case + (progn + (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))))) + (defun terminate-session () #!+sb-doc "Kill all threads in session except for this one. Does nothing if current @@ -1223,9 +1343,14 @@ have the foreground next." (defun make-thread (function &key name arguments) #!+sb-doc "Create a new thread of NAME that runs FUNCTION with the argument -list designator provided (defaults to no argument). When the function -returns the thread exits. The return values of FUNCTION are kept -around and can be retrieved by JOIN-THREAD." +list designator provided (defaults to no argument). Thread exits when +the function returns. The return values of FUNCTION are kept around +and can be retrieved by JOIN-THREAD. + +Invoking the initial ABORT restart estabilished by MAKE-THREAD +terminates the thread. + +See also: RETURN-FROM-THREAD, ABORT-THREAD." #!-sb-thread (declare (ignore function name arguments)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (assert (or (atom arguments) @@ -1234,116 +1359,118 @@ around and can be retrieved by JOIN-THREAD." "Argument passed to ~S, ~S, is an improper list." 'make-thread arguments) #!+sb-thread - (let* ((thread (%make-thread :name name)) - (setup-sem (make-semaphore :name "Thread setup semaphore")) - (real-function (coerce function 'function)) - (arguments (if (listp arguments) - arguments - (list arguments))) - (initial-function - (named-lambda initial-thread-function () - ;; In time we'll move some of the binding presently done in C - ;; here too. - ;; - ;; KLUDGE: Here we have a magic list of variables that are - ;; not thread-safe for one reason or another. As people - ;; report problems with the thread safety of certain - ;; variables, (e.g. "*print-case* in multiple threads - ;; broken", sbcl-devel 2006-07-14), we add a few more - ;; bindings here. The Right Thing is probably some variant - ;; of Allegro's *cl-default-special-bindings*, as that is at - ;; least accessible to users to secure their own libraries. - ;; --njf, 2006-07-15 - ;; - ;; As it is, this lambda must not cons until we are ready - ;; to run GC. Be very careful. - (let* ((*current-thread* thread) - (*restart-clusters* nil) - (*handler-clusters* (sb!kernel::initial-handler-clusters)) - (*condition-restarts* nil) - (sb!impl::*deadline* nil) - (sb!impl::*deadline-seconds* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (sb!impl::*internal-symbol-output-fun* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - ;; Binding from C - (setf sb!vm:*alloc-signal* *default-alloc-signal*) - (setf (thread-os-thread thread) (current-thread-os-thread)) - (with-mutex ((thread-result-lock thread)) - (with-all-threads-lock - (push thread *all-threads*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (setf (thread-%alive-p thread) t) - (signal-semaphore setup-sem) - ;; can't use handling-end-of-the-world, because that flushes - ;; output streams, and we don't necessarily have any (or we - ;; could be sharing them) - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil - "~~@" - *current-thread*)) - (without-interrupts - (unwind-protect - (with-local-interrupts - ;; Now that most things have a chance - ;; to work properly without messing up - ;; other threads, it's time to enable - ;; signals. - (sb!unix::unblock-deferrable-signals) - (setf (thread-result thread) - (cons t - (multiple-value-list - (apply real-function arguments)))) - ;; Try to block deferrables. An - ;; interrupt may unwind it, but for a - ;; normal exit it prevents interrupt - ;; loss. - (block-deferrable-signals)) - ;; We're going down, can't handle interrupts - ;; sanely anymore. GC remains enabled. - (block-deferrable-signals) - ;; We don't want to run interrupts in a dead - ;; thread when we leave WITHOUT-INTERRUPTS. - ;; This potentially causes important - ;; interupts to be lost: SIGINT comes to - ;; mind. - (setq *interrupt-pending* nil) - (handle-thread-exit thread)))))))) - (values)))) - ;; If the starting thread is stopped for gc before it signals the - ;; semaphore then we'd be stuck. - (assert (not *gc-inhibit*)) - ;; Keep INITIAL-FUNCTION pinned until the child thread is - ;; initialized properly. Wrap the whole thing in - ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another - ;; thread. - (without-interrupts - (with-pinned-objects (initial-function) - (let ((os-thread - (%create-thread - (get-lisp-obj-address initial-function)))) - (when (zerop os-thread) - (error "Can't create a new thread")) - (wait-on-semaphore setup-sem) - thread))))) + (tagbody + (with-mutex (*make-thread-lock*) + (let* ((thread (%make-thread :name name)) + (setup-sem (make-semaphore :name "Thread setup semaphore")) + (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) + (initial-function + (named-lambda initial-thread-function () + ;; In time we'll move some of the binding presently done in C + ;; here too. + ;; + ;; KLUDGE: Here we have a magic list of variables that are + ;; not thread-safe for one reason or another. As people + ;; report problems with the thread safety of certain + ;; variables, (e.g. "*print-case* in multiple threads + ;; broken", sbcl-devel 2006-07-14), we add a few more + ;; bindings here. The Right Thing is probably some variant + ;; of Allegro's *cl-default-special-bindings*, as that is at + ;; least accessible to users to secure their own libraries. + ;; --njf, 2006-07-15 + ;; + ;; As it is, this lambda must not cons until we are ready + ;; to run GC. Be very careful. + (let* ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) + (*condition-restarts* nil) + (*exit-in-process* nil) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) + (with-mutex ((thread-result-lock thread)) + (with-all-threads-lock + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (signal-semaphore setup-sem) + ;; Using handling-end-of-the-world would be a bit tricky + ;; due to other catches and interrupts, so we essentially + ;; re-implement it here. Once and only once more. + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (catch '%abort-thread + (with-simple-restart + (abort "~@" *current-thread*) + (without-interrupts + (unwind-protect + (with-local-interrupts + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (cons t + (multiple-value-list + (unwind-protect + (catch '%return-from-thread + (apply real-function arguments)) + (when *exit-in-process* + (sb!impl::call-exit-hooks))))))) + ;; We're going down, can't handle interrupts + ;; sanely anymore. GC remains enabled. + (block-deferrable-signals) + ;; We don't want to run interrupts in a dead + ;; thread when we leave WITHOUT-INTERRUPTS. + ;; This potentially causes important + ;; interupts to be lost: SIGINT comes to + ;; mind. + (setq *interrupt-pending* nil) + (handle-thread-exit thread))))))))) + (values)))) + ;; If the starting thread is stopped for gc before it signals the + ;; semaphore then we'd be stuck. + (assert (not *gc-inhibit*)) + ;; Keep INITIAL-FUNCTION pinned until the child thread is + ;; initialized properly. Wrap the whole thing in + ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another + ;; thread. + (without-interrupts + (with-pinned-objects (initial-function) + (let ((os-thread + (%create-thread + (get-lisp-obj-address initial-function)))) + (when (zerop os-thread) + (go :cant-spawn)) + (wait-on-semaphore setup-sem) + (return-from make-thread thread)))))) + :cant-spawn + (error "Could not create a new thread."))) (defun join-thread (thread &key (default nil defaultp) timeout) #!+sb-doc - "Suspend current thread until THREAD exits. Return the result values of the -thread function. + "Suspend current thread until THREAD exits. Return the result values +of the thread function. + +If the thread does not exit normally within TIMEOUT seconds return +DEFAULT if given, or else signal JOIN-THREAD-ERROR. -If the thread does not exit normally within TIMEOUT seconds return DEFAULT if -given, or else signal JOIN-THREAD-ERROR. +Trying to join the main thread will cause JOIN-THREAD to block until +TIMEOUT occurs or the process exits: when main thread exits, the +entire process exits. -NOTE: Return convention in case of a timeout is exprimental and subject to -change." +NOTE: Return convention in case of a timeout is exprimental and +subject to change." (let ((lock (thread-result-lock thread)) (got-it nil) (problem :timeout)) @@ -1468,11 +1595,11 @@ Short version: be careful out there." (defun terminate-thread (thread) #!+sb-doc - "Terminate the thread identified by THREAD, by interrupting it and causing -it to call SB-EXT:QUIT. + "Terminate the thread identified by THREAD, by interrupting it and +causing it to call SB-EXT:ABORT-THREAD with :ALLOW-EXIT T. -The unwind caused by TERMINATE-THREAD is asynchronous, meaning that eg. thread -executing +The unwind caused by TERMINATE-THREAD is asynchronous, meaning that +eg. thread executing (let (foo) (unwind-protect @@ -1485,12 +1612,12 @@ executing ;; to be dropped. (release-foo foo)))) -might miss calling RELEASE-FOO despite GET-FOO having returned true if the -interrupt occurs inside the cleanup clause, eg. during execution of -RELEASE-FOO. +might miss calling RELEASE-FOO despite GET-FOO having returned true if +the interrupt occurs inside the cleanup clause, eg. during execution +of RELEASE-FOO. -Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need to use -WITHOUT-INTERRUPTS: +Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need +to use WITHOUT-INTERRUPTS: (let (foo) (sb-sys:without-interrupts @@ -1505,7 +1632,7 @@ WITHOUT-INTERRUPTS: Since most libraries using UNWIND-PROTECT do not do this, you should never assume that unknown code can safely be terminated using TERMINATE-THREAD." - (interrupt-thread thread 'sb!ext:quit)) + (interrupt-thread thread (lambda () (abort-thread :allow-exit t)))) (define-alien-routine "thread_yield" int) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 7384972..9fa8189 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -75,29 +75,45 @@ 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) + (unwind-protect + (progn + (flush-standard-output-streams) + (sb!thread::%exit-other-threads) + (setf ok t)) + (os-exit *exit-in-process* :abort (not ok)))))) ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* @@ -315,7 +331,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 +346,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 +363,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 +373,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 () @@ -519,11 +535,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 +616,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) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 248f72e..2373feb 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -427,9 +427,14 @@ corresponds to NAME, or NIL if there is none." ;;; Terminate the current process with an optional error code. If ;;; successful, the call doesn't return. If unsuccessful, the call ;;; returns NIL and an error number. -(defun unix-exit (&optional (code 0)) - (declare (type (signed-byte 32) code)) - (void-syscall ("exit" int) code)) +(deftype exit-code () + `(signed-byte 32)) +(defun os-exit (code &key abort) + (unless (typep code 'exit-code) + (setf code (if abort 1 0))) + (if abort + (void-syscall ("_exit" int) code) + (void-syscall ("exit" int) code))) ;;; Return the process id of the current process. (define-alien-routine ("getpid" unix-getpid) int) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 22a2eae..d08bb70 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -15,7 +15,7 @@ ;;; callbacks only on a few platforms #-alien-callbacks -(quit :unix-status 104) +(exit :code 104) ;;; simple callback for a function diff --git a/tests/clos-cache.impure.lisp b/tests/clos-cache.impure.lisp index c3e07d6..46e1a1a 100644 --- a/tests/clos-cache.impure.lisp +++ b/tests/clos-cache.impure.lisp @@ -72,7 +72,7 @@ (error (e) (note "~&Error in cache test in ~S:~%~A~%...aborting" sb-thread:*current-thread* e) - (sb-ext:quit :unix-status 1))) + (sb-ext:exit :code 1))) (note "/~S done" sb-thread:*current-thread*)) #+sb-thread diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index bf8e74b..b5d6512 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -16,7 +16,7 @@ ;;;; more information. (when (eq sb-ext:*evaluator-mode* :interpret) - (sb-ext:quit :unix-status 104)) + (sb-ext:exit :code 104)) (load "test-util.lisp") (load "compiler-test-util.lisp") diff --git a/tests/condition-wait-sigcont.lisp b/tests/condition-wait-sigcont.lisp index 04fd5cd..c4c4312 100644 --- a/tests/condition-wait-sigcont.lisp +++ b/tests/condition-wait-sigcont.lisp @@ -35,4 +35,4 @@ ;; sleep a bit so our runner can kill us (sleep 10) -(quit) +(exit) diff --git a/tests/core.test.sh b/tests/core.test.sh index 9ffec8c..02d3d47 100644 --- a/tests/core.test.sh +++ b/tests/core.test.sh @@ -39,7 +39,7 @@ run_sbcl < "$tmpoutput" --no-userinit --no-sysinit --noprint < $TEST_FILESTEM.base.lisp < $TEST_FILESTEM.test.lisp <>>~a<<<~%" test-util::*failures*))) (test-util:report-test-status) - (sb-ext:quit :unix-status 104))))) + (sb-ext:exit :code 104))))) (defun impure-runner (files test-fun) (format t "// Running impure tests (~a)~%" test-fun) @@ -211,7 +211,7 @@ :output *error-output*))) (let ((*failures* nil)) (test-util:report-test-status)) - (sb-ext:quit :unix-status (process-exit-code process)))) + (sb-ext:exit :code (process-exit-code process)))) (defun accept-test-file (file) (if *accept-files* diff --git a/tests/script.test.sh b/tests/script.test.sh index 87a2e08..33483ba 100644 --- a/tests/script.test.sh +++ b/tests/script.test.sh @@ -21,9 +21,9 @@ tmpscript=$TEST_FILESTEM.lisp-script tmpout=$TEST_FILESTEM.lisp-out tmperr=$TEST_FILESTEM.lisp-err -echo '(quit :unix-status 7)' > $tmpscript +echo '(exit :code 7)' > $tmpscript run_sbcl --script $tmpscript -check_status_maybe_lose "--script exit status from QUIT" $? 7 "(quit status good)" +check_status_maybe_lose "--script exit status from EXIT" $? 7 "(status good)" echo '(error "oops")' > $tmpscript run_sbcl --script $tmpscript 1> $tmpout 2> $tmperr @@ -40,7 +40,7 @@ check_status_maybe_lose "--script exit status from normal exit" $? 0 "(everythin cat > $tmpscript </dev/null check_status_maybe_lose "--script exit status from QUIT when standard-output closed" $? 3 "(as given)" @@ -61,9 +61,9 @@ cat > $tmpscript </dev/null -check_status_maybe_lose "--script exit status from QUIT when stdout closed" $? 3 "(as given)" +check_status_maybe_lose "--script exit status from EXIT when stdout closed" $? 3 "(as given)" run_sbcl --load $tmpscript >/dev/null -check_status_maybe_lose "--load exit status from QUIT when stdout closed" $? 3 "(as given)" +check_status_maybe_lose "--load exit status from EXIT when stdout closed" $? 3 "(as given)" cat > $tmpscript < $tmpfilename < $tmpfilename < $tmpfilename.out check_status_maybe_lose bivalent-standard-output $? @@ -52,7 +52,7 @@ cat > $tmpfilename < $tmpfilename.out check_status_maybe_lose bivalent-error-output $? diff --git a/tests/stress-gc.sh b/tests/stress-gc.sh index 36ef336..386e903 100644 --- a/tests/stress-gc.sh +++ b/tests/stress-gc.sh @@ -18,7 +18,7 @@ run_sbcl <