Menu
▾
▴
[Sbcl-commits] master: redesign exiting SBCL
|
From: Nikodemus S. <de...@us...> - 2012-04-29 18:47:43
|
The branch "master" has been updated in SBCL:
via f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0 (commit)
from 4ce962e92568e52624959d8abc83f609abc3605c (commit)
- Log -----------------------------------------------------------------
commit f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0
Author: Nikodemus Siivola <nik...@ra...>
Date: Tue Dec 6 13:44:06 2011 +0200
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.
---
NEWS | 6 +
contrib/asdf-module.mk | 2 +-
contrib/sb-aclrepl/repl.lisp | 4 +-
contrib/sb-concurrency/tests/test-gate.lisp | 2 +-
contrib/sb-executable/sb-executable.lisp | 2 +-
contrib/sb-posix/posix-tests.lisp | 12 +-
doc/manual/create-contrib-doc-list.lisp | 2 +-
doc/manual/make-tempfiles.sh | 6 +-
doc/manual/start-stop.texinfo | 15 +-
doc/manual/threading.texinfo | 11 +-
doc/sbcl.1 | 2 +-
make-windows-installer.sh | 2 +-
package-data-list.lisp-expr | 19 ++-
src/code/cold-init.lisp | 66 ++++-
src/code/deadline.lisp | 14 +-
src/code/debug.lisp | 6 +-
src/code/save.lisp | 3 +
src/code/target-signal.lisp | 3 +-
src/code/target-thread.lisp | 367 +++++++++++++++++---------
src/code/toplevel.lisp | 80 ++++---
src/code/unix.lisp | 11 +-
tests/callback.impure.lisp | 2 +-
tests/clos-cache.impure.lisp | 2 +-
tests/compiler.impure.lisp | 2 +-
tests/condition-wait-sigcont.lisp | 2 +-
tests/core.test.sh | 14 +-
tests/custom-userinit.lisp | 2 +-
tests/debug.impure.lisp | 2 +-
tests/dynamic-extent.impure.lisp | 2 +-
tests/enc-cn.impure.lisp | 2 +-
tests/enc-jpn.impure.lisp | 2 +-
tests/external-format.impure.lisp | 2 +-
tests/filesys.test.sh | 18 +-
tests/foreign.test.sh | 14 +-
tests/full-eval.impure.lisp | 2 +-
tests/interface.test.sh | 18 ++
tests/kill-non-lisp-thread.impure.lisp | 2 +-
tests/run-tests.lisp | 10 +-
tests/script.test.sh | 10 +-
tests/step.impure.lisp | 2 +-
tests/stream.test.sh | 8 +-
tests/stress-gc.sh | 2 +-
tests/swap-lispobjs.impure.lisp | 2 +-
tests/threads.impure.lisp | 20 +-
tests/threads.pure.lisp | 31 +++
tests/threads.test.sh | 9 +
tests/undefined-classoid-bug.test.sh | 4 +-
tests/unwind-to-frame-and-call.impure.lisp | 2 +-
tests/win32-foreign-stack-unwind.impure.lisp | 2 +-
tools-for-build/ldso-stubs.lisp | 3 +-
50 files changed, 553 insertions(+), 275 deletions(-)
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 <<EOF
(dolist (module (quote ($MODULES)))
(require module))
(sb-texinfo:generate-includes "$DOCSTRINGDIR" $PACKAGES)
-(sb-ext:quit))
+(sb-ext:exit))
EOF
echo /creating package-locks.texi-temp
-if $SBCL --eval "(let ((plp (find-symbol \"PACKAGE-LOCKED-P\" :sb-ext))) (quit :unix-status (if (and plp (fboundp plp)) 0 1)))";
+if $SBCL --eval "(let ((plp (find-symbol \"PACKAGE-LOCKED-P\" :sb-ext))) (exit :code (if (and plp (fboundp plp)) 0 1)))";
then
cp package-locks-extended.texinfo package-locks.texi-temp
else
diff --git a/doc/manual/start-stop.texinfo b/doc/manual/start-stop.texinfo
index ece3c90..7e27d51 100644
--- a/doc/manual/start-stop.texinfo
+++ b/doc/manual/start-stop.texinfo
@@ -41,7 +41,7 @@ distribution for more information.
* (+ 2 2)
4
-* (quit)
+* (exit)
$
@end smallexample
@@ -96,22 +96,21 @@ Hello, World!
@section Stopping SBCL
@menu
-* Quit::
+* Exit::
* End of File::
* Saving a Core Image::
* Exit on Errors::
@end menu
-@node Quit
+@node Exit
@comment node-name, next, previous, up
-@subsection Quit
+@subsection Exit
-SBCL can be stopped at any time by calling @code{sb-ext:quit},
+SBCL can be stopped at any time by calling @code{sb-ext:exit},
optionally returning a specified numeric value to the calling process.
-See notes in @ref{Threading} about the interaction between this
-feature and sessions.
+See @ref{Threading} for information about terminating individual threads.
-@include fun-sb-ext-quit.texinfo
+@include fun-sb-ext-exit.texinfo
@node End of File
@comment node-name, next, previous, up
diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo
index 21d2756..0f01ba6 100644
--- a/doc/manual/threading.texinfo
+++ b/doc/manual/threading.texinfo
@@ -44,12 +44,16 @@ directions.
@include fun-sb-thread-list-all-threads.texinfo
@include fun-sb-thread-thread-alive-p.texinfo
@include fun-sb-thread-thread-name.texinfo
+@include fun-sb-thread-main-thread-p.texinfo
+@include fun-sb-thread-main-thread.texinfo
-@subsection Making, Joining, and Yielding Threads
+@subsection Making, Returning From, Joining, and Yielding Threads
@include fun-sb-thread-make-thread.texinfo
-@include fun-sb-thread-thread-yield.texinfo
+@include macro-sb-thread-return-from-thread.texinfo
+@include fun-sb-thread-abort-thread.texinfo
@include fun-sb-thread-join-thread.texinfo
+@include fun-sb-thread-thread-yield.texinfo
@subsection Asynchronous Operations
@@ -318,9 +322,6 @@ it back into the background before it resumes. Arbitration for the
input stream is managed by calls to @code{sb-thread:get-foreground}
(which may block) and @code{sb-thread:release-foreground}.
-@code{sb-ext:quit} terminates all threads in the current session, but
-leaves other sessions running.
-
@node Foreign threads
@comment node-name, next, previous, up
@section Foreign threads
diff --git a/doc/sbcl.1 b/doc/sbcl.1
index c088876..5f44109 100644
--- a/doc/sbcl.1
+++ b/doc/sbcl.1
@@ -47,7 +47,7 @@ wait for your next input.
* (+ 1 2 3)
6
- * (quit)
+ * (exit)
\fR
Most people like to run SBCL as a subprocess under Emacs. The Emacs
diff --git a/make-windows-installer.sh b/make-windows-installer.sh
index 7c89e5f..dc05a22 100644
--- a/make-windows-installer.sh
+++ b/make-windows-installer.sh
@@ -27,7 +27,7 @@ cd output
:direction :output
:if-exists :supersede)
(write-line (lisp-implementation-version) f))
- (quit))'
+ (exit))'
"$WIX_PATH/candle" sbcl.wxs
"$WIX_PATH/light" sbcl.wixobj "$WIX_PATH/wixui.wixlib" \
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index a8c7825..3a6b84a 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -650,6 +650,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
;; Hooks into init & save sequences
"*INIT-HOOKS*" "*SAVE-HOOKS*" "*EXIT-HOOKS*"
+ ;; Controlling exiting other threads.
+ "*EXIT-TIMEOUT*"
+
;; There is no one right way to report progress on
;; hairy compiles.
"*COMPILE-PROGRESS*"
@@ -797,7 +800,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"*INVOKE-DEBUGGER-HOOK*"
;; miscellaneous useful supported extensions
- "QUIT"
+ "QUIT" "EXIT"
"*ED-FUNCTIONS*"
"*MODULE-PROVIDER-FUNCTIONS*"
"WITH-TIMEOUT" "TIMEOUT"
@@ -1317,7 +1320,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%CONCATENATE-TO-STRING"
"%COS" "%COS-QUICK"
"%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
- "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1"
+ "%DOUBLE-FLOAT" "%DPB" "%EQL"
+ "%EXIT"
+ "%EXP" "%EXPM1"
"%FLOOR"
"%FIND-POSITION"
"%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
@@ -1986,6 +1991,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"INTERRUPT-THREAD"
"INTERRUPT-THREAD-ERROR"
"INTERRUPT-THREAD-ERROR-THREAD"
+ "RETURN-FROM-THREAD"
+ "ABORT-THREAD"
+ "MAIN-THREAD-P"
+ "MAIN-THREAD"
"JOIN-THREAD"
"JOIN-THREAD-ERROR"
"JOIN-THREAD-ERROR-THREAD"
@@ -2317,6 +2326,8 @@ SB-KERNEL) have been undone, but probably more remain."
;; SB!KERNEL.)
"%PRIMITIVE"
"%STANDARD-CHAR-P"
+ "*EXIT-ERROR-HANDLER*"
+ "*EXIT-IN-PROCESS*"
"*ALLOW-WITH-INTERRUPTS*"
"*INTERRUPTS-ENABLED*"
"*INTERRUPT-PENDING*"
@@ -2349,6 +2360,7 @@ SB-KERNEL) have been undone, but probably more remain."
"ENABLE-INTERRUPT"
"ENSURE-DYNAMIC-FOREIGN-SYMBOL-ADDRESS"
"EXTERN-ALIEN-NAME"
+ "EXIT-CODE"
"FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P"
"FIND-DYNAMIC-FOREIGN-SYMBOL-ADDRESS"
"FIND-FOREIGN-SYMBOL-ADDRESS"
@@ -2368,6 +2380,7 @@ SB-KERNEL) have been undone, but probably more remain."
"MACRO" "MAKE-FD-STREAM"
"MEMORY-FAULT-ERROR"
"MEMMOVE"
+ "OS-EXIT"
"OS-COLD-INIT-OR-REINIT" "OS-CONTEXT-T" "OUTPUT-RAW-BYTES"
"READ-N-BYTES"
"REMOVE-FD-HANDLER"
@@ -2453,7 +2466,7 @@ no guarantees of interface stability."
"TIOCGPGRP" "TIOCGWINSZ" "TIOCNOTTY" "TIOCSETC" "TIOCSETP"
"TIOCSLTC" "TIOCSPGRP" "TIOCSWINSZ" "TV-SEC" "TV-USEC"
"TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-CLOSE"
- "UNIX-CLOSEDIR" "UNIX-DIRENT-NAME" "UNIX-DUP""UNIX-EXIT"
+ "UNIX-CLOSEDIR" "UNIX-DIRENT-NAME" "UNIX-DUP"
"UNIX-FILE-MODE" "UNIX-FSTAT"
"UNIX-GETHOSTNAME" "UNIX-GETPID" "UNIX-GETRUSAGE"
"UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID" "UNIX-IOCTL"
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 8444234..df0c1ce 100644
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -276,17 +276,63 @@
(defun quit (&key recklessly-p (unix-status 0))
#!+sb-doc
- "Terminate the current Lisp. *EXIT-HOOKS* and pending unwind-protect
-cleanup forms are run unless RECKLESSLY-P is true. On UNIX-like
-systems, UNIX-STATUS is used as the status code."
- (declare (type (signed-byte 32) unix-status))
- ;; FIXME: Windows is not "unix-like", but still has the same
- ;; unix-status... maybe we should just revert to calling it :STATUS?
- (/show0 "entering QUIT")
- (if recklessly-p
- (sb!unix:unix-exit unix-status)
- (throw '%end-of-the-world unix-status))
+ "Deprecated. See: SB-EXT:EXIT, SB-THREAD:RETURN-FROM-THREAD,
+SB-THREAD:ABORT-THREAD."
+ (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(2) -- 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(2).
+
+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 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.
+
+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."))
;;;; initialization functions
diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp
index 5252a11..d2577dc 100644
--- a/src/code/deadline.lisp
+++ b/src/code/deadline.lisp
@@ -43,18 +43,22 @@ not extended. Deadlines are per thread: children are unaffected by
their parent's deadlines.
Experimental."
- (with-unique-names (deadline-seconds deadline)
+ (with-unique-names (tmp deadline-seconds deadline)
;; We're operating on a millisecond precision, so a single-float
;; is enough, and is an immediate on 64bit platforms.
- `(let* ((,deadline-seconds (coerce ,seconds 'single-float))
+ `(let* ((,tmp ,seconds)
+ (,deadline-seconds
+ (when ,tmp
+ (coerce ,tmp 'single-float)))
(,deadline
- (+ (seconds-to-internal-time ,deadline-seconds)
- (get-internal-real-time))))
+ (when ,deadline-seconds
+ (+ (seconds-to-internal-time ,deadline-seconds)
+ (get-internal-real-time)))))
(multiple-value-bind (*deadline* *deadline-seconds*)
(if ,override
(values ,deadline ,deadline-seconds)
(let ((old *deadline*))
- (if (and old (< old ,deadline))
+ (if (and old (or (not ,deadline) (< old ,deadline)))
(values old *deadline-seconds*)
(values ,deadline ,deadline-seconds))))
,@body))))
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 5190f3f..9a9db8b 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -672,9 +672,9 @@ reset to ~S."
(declare (ignore me))
;; There is no one there to interact with, so report the
;; condition and terminate the program.
- (flet ((failure-quit (&key recklessly-p)
+ (flet ((failure-quit (&key abort)
(/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
- (quit :unix-status 1 :recklessly-p recklessly-p)))
+ (exit :code 1 :abort abort)))
;; This HANDLER-CASE is here mostly to stop output immediately
;; (and fall through to QUIT) when there's an I/O error. Thus,
;; when we're run under a shell script or something, we can die
@@ -724,7 +724,7 @@ reset to ~S."
(ignore-errors
(%primitive print
"Argh! error within --disable-debugger error handling"))
- (failure-quit :recklessly-p t)))))
+ (failure-quit :abort t)))))
(defvar *old-debugger-hook* nil)
diff --git a/src/code/save.lisp b/src/code/save.lisp
index c6ec320..fa99ce0 100644
--- a/src/code/save.lisp
+++ b/src/code/save.lisp
@@ -57,6 +57,9 @@ The following &KEY arguments are defined:
and runs the top level read-eval-print loop. This function returning
is equivalent to (SB-EXT:QUIT :UNIX-STATUS 0) being called.
+ TOPLEVEL functions should always provide an ABORT restart: otherwise
+ code they call will run without one.
+
:EXECUTABLE
If true, arrange to combine the SBCL runtime and the core image
to create a standalone executable. If false (the default), the
diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 2ae4a88..840604e 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -197,8 +197,7 @@
(defun sigterm-handler (signal code context)
(declare (ignore signal code context))
- (sb!thread::terminate-session)
- (sb!ext:quit))
+ (sb!ext:exit))
;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
;;; for signalling a thread that it should look at its interruption
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 080c173..d5a3331 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -74,6 +74,9 @@ WITH-CAS-LOCK can be entered recursively."
The offending thread is initialized by the :THREAD initialization argument and
read by the function THREAD-ERROR-THREAD."))
+(define-condition simple-thread-error (thread-error simple-condition)
+ ())
+
(define-condition thread-deadlock (thread-error)
((cycle :initarg :cycle :reader thread-deadlock-cycle))
(:report
@@ -248,16 +251,88 @@ created and old ones may exit at any time."
#!-sb-thread
0)
+(defvar *initial-thread* nil)
+(defvar *make-thread-lock*)
+
(defun init-initial-thread ()
(/show0 "Entering INIT-INITIAL-THREAD")
- (let ((initial-thread (%make-thread :name "initial thread"
+ (setf sb!impl::*exit-lock* (make-mutex :name "Exit Lock")
+ *make-thread-lock* (make-mutex :name "Make-Thread Lock"))
+ (let ((initial-thread (%make-thread :name "main thread"
:%alive-p t
:os-thread (current-thread-os-thread))))
- (setq *current-thread* initial-thread)
+ (setq *initial-thread* initial-thread
+ *current-thread* initial-thread)
+ (grab-mutex (thread-result-lock *initial-thread*))
;; Either *all-threads* is empty or it contains exactly one thread
;; in case we are in reinit since saving core with multiple
;; threads doesn't work.
(setq *all-threads* (list initial-thread))))
+
+(defun main-thread ()
+ "Returns the main thread of the process."
+ *initial-thread*)
+
+(defun main-thread-p (&optional (thread *current-thread*))
+ "True if THREAD, defaulting to current thread, is the main thread of the process."
+ (eq thread *initial-thread*))
+
+(defmacro return-from-thread (values-form &key allow-exit)
+ "Unwinds from and terminates the current thread, with values from
+VALUES-FORM as the results visible to JOIN-THREAD.
+
+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, returning from the main thread is equivalent to
+calling SB-EXT:EXIT with :CODE 0 and :ABORT NIL.
+
+See also: ABORT-THREAD and SB-EXT:EXIT."
+ `(%return-from-thread (multiple-value-list ,values-form) ,allow-exit))
+
+(defun %return-from-thread (values allow-exit)
+ (let ((self *current-thread*))
+ (cond ((main-thread-p self)
+ (unless allow-exit
+ (error 'simple-thread-error
+ :format-control "~@<Tried to return ~S as values from main thread, ~
+ but exit was not allowed.~:@>"
+ :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 "~@<Tried to abort initial thread, but ~
+ exit was not allowed.~:@>"))
+ (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
- "~~@<Terminate this thread (~A)~~@:>"
- *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 "~@<Abort thread (~A)~@:>" *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.
-NOTE: Return convention in case of a timeout is exprimental and subject to
-change."
+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."
(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 <<EOF
(save-lisp-and-die "$tmpcore")
EOF
run_sbcl_with_core "$tmpcore" --no-userinit --no-sysinit <<EOF
- (quit :unix-status (foo 10))
+ (exit :code (foo 10))
EOF
check_status_maybe_lose "Basic SAVE-LISP-AND-DIE" $? 21 "(saved core ran)"
@@ -47,11 +47,11 @@ check_status_maybe_lose "Basic SAVE-LISP-AND-DIE" $? 21 "(saved core ran)"
run_sbcl <<EOF
(defun bar ()
(format t "~&Callbacks not supported, skipping~%")
- (quit :unix-status 42))
+ (exit :code 42))
#+alien-callbacks
(progn
(sb-alien::define-alien-callback foo int () 42)
- (defun bar () (quit :unix-status (alien-funcall foo))))
+ (defun bar () (exit :code (alien-funcall foo))))
(save-lisp-and-die "$tmpcore")
EOF
run_sbcl_with_core "$tmpcore" --no-userinit --no-sysinit <<EOF
@@ -66,7 +66,7 @@ run_sbcl <<EOF
EOF
chmod u+x "$tmpcore"
./"$tmpcore" > "$tmpoutput" --no-userinit --no-sysinit --noprint <<EOF
- (quit :unix-status 71)
+ (exit :code 71)
EOF
status=$?
if [ $status != 71 ]; then
@@ -94,9 +94,9 @@ chmod u+x "$tmpcore"
(save-lisp-and-die "$tmpcore" :executable t :save-runtime-options t)
EOF
chmod u+x "$tmpcore"
-./"$tmpcore" --no-userinit --version --eval '(quit)' <<EOF
- (when (equal *posix-argv* '("./$tmpcore" "--version" "--eval" "(quit)"))
- (quit :unix-status 42))
+./"$tmpcore" --no-userinit --version --eval '(exit)' <<EOF
+ (when (equal *posix-argv* '("./$tmpcore" "--version" "--eval" "(exit)"))
+ (exit :code 42))
EOF
status=$?
if [ $status != 42 ]; then
diff --git a/tests/custom-userinit.lisp b/tests/custom-userinit.lisp
index 38c71b6..68a57d9 100644
--- a/tests/custom-userinit.lisp
+++ b/tests/custom-userinit.lisp
@@ -14,4 +14,4 @@
(write-line "/loading custom userinit")
(defun userinit-quit (x)
- (sb-ext:quit :unix-status x))
+ (sb-ext:exit :code x))
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 208cbe8..52c106c 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -17,7 +17,7 @@
;;; The debugger doesn't have any native knowledge of the interpreter
(when (eq sb-ext:*evaluator-mode* :interpret)
- (sb-ext:quit :unix-status 104))
+ (sb-ext:exit :code 104))
;;;; Check that we get debug arglists right.
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index dd256ac..ff26c1d 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -12,7 +12,7 @@
;;;; more information.
(when (eq sb-ext:*evaluator-mode* :interpret)
- (sb-ext:quit :unix-status 104))
+ (sb-ext:exit :code 104))
(load "compiler-test-util.lisp")
(use-package :ctu)
diff --git a/tests/enc-cn.impure.lisp b/tests/enc-cn.impure.lisp
index a978d1f..ebb7c84 100644
--- a/tests/enc-cn.impure.lisp
+++ b/tests/enc-cn.impure.lisp
@@ -1,7 +1,7 @@
;;; -*- coding: utf-8 -*-
;;; enc-cn.impure.lisp: test case for enc-cn.lisp and enc-cn-tbl.lisp
#-sb-unicode
-(sb-ext:quit :unix-status 104)
+(sb-ext:exit :code 104)
;; use "1AＡãè¡ç¥å§®" for tests
(let ((str (coerce '(#\u0031 #\u0041 #\uff21 #\u3042 #\u80e1 #\u73a5 #\u59ee)
diff --git a/tests/enc-jpn.impure.lisp b/tests/enc-jpn.impure.lisp
index 9851be4..132adda 100644
--- a/tests/enc-jpn.impure.lisp
+++ b/tests/enc-jpn.impure.lisp
@@ -1,6 +1,6 @@
;; -*- coding: utf-8 -*-
#-sb-unicode
-(sb-ext:quit :unix-status 104)
+(sb-ext:exit :code 104)
;; use "AｱＡãæ¼¾ç¹é" for tests
(let ((str (coerce '(#\u0041 #\uff71 #\uff21 #\u3042 #\u6f3e #\u71f9 #\u91ed)
diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp
index bd521f8..d8888c1 100644
--- a/tests/external-format.impure.lisp
+++ b/tests/external-format.impure.lisp
@@ -53,7 +53,7 @@
#-sb-unicode
(progn
(test-util:report-test-status)
- (sb-ext:quit :unix-status 104))
+ (sb-ext:exit :code 104))
;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh
index 0ca9cb5..d2082b6 100644
--- a/tests/filesys.test.sh
+++ b/tests/filesys.test.sh
@@ -59,7 +59,7 @@ run_sbcl <<EOF
(assert (equal (truename "link-4") #p"$testdir/link-4"))
(assert (equal (truename "link-5") #p"$testdir/link-5"))
(assert (equal (truename "link-6") #p"$testdir/link-6"))
- (sb-ext:quit :unix-status $EXIT_LISP_WIN)
+ (sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 1" $?
@@ -78,7 +78,7 @@ run_sbcl <<EOF
(assert (equal (truename "$testdir/link-4") #p"$testdir/link-4"))
(assert (equal (truename "$testdir/link-5") #p"$testdir/link-5"))
(assert (equal (truename "$testdir/link-6") #p"$testdir/link-6"))
- (sb-ext:quit :unix-status $EXIT_LISP_WIN)
+ (sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 2" $?
cleanup_test_subdirectory
@@ -194,7 +194,7 @@ Lisp filename syntax idiosyncrasies)."
#...
[truncated message content] |