common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

redesign exiting SBCL

Browse source 
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.
This commit is contained in:
Nikodemus Siivola 2011-12-06 13:44:06 +02:00
parent 4ce962e925
commit f0da2f63aa
50 changed files with 553 additions and 275 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
NEWS
View file

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

2
contrib/asdf-module.mk
View file

@ -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))" \

4
contrib/sb-aclrepl/repl.lisp
View file

@ -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*)

2
contrib/sb-concurrency/tests/test-gate.lisp
View file

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

2
contrib/sb-executable/sb-executable.lisp
View file

@ -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

12
contrib/sb-posix/posix-tests.lisp
View file

@ -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

2
doc/manual/create-contrib-doc-list.lisp
View file

@ -39,4 +39,4 @@
:name (pathname-name texi-file)
:type (pathname-type texi-file)))))))
(sb-ext:quit)
(sb-ext:exit)

6
doc/manual/make-tempfiles.sh
View file

@ -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

15
doc/manual/start-stop.texinfo
View file

@ -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

11
doc/manual/threading.texinfo
View file

@ -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

2
doc/sbcl.1
View file

@ -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

2
make-windows-installer.sh
View file

@ -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" \

19
package-data-list.lisp-expr
View file

@ -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"

66
src/code/cold-init.lisp
View file

@ -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

14
src/code/deadline.lisp
View file

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

6
src/code/debug.lisp
View file

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

3
src/code/save.lisp
View file

@ -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

3
src/code/target-signal.lisp
View file

@ -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

367
src/code/target-thread.lisp
View file

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

80
src/code/toplevel.lisp
View file

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

11
src/code/unix.lisp
View file

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

2
tests/callback.impure.lisp
View file

@ -15,7 +15,7 @@
;;; callbacks only on a few platforms
#-alien-callbacks
(quit :unix-status 104)
(exit :code 104)
;;; simple callback for a function

2
tests/clos-cache.impure.lisp
View file

@ -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

2
tests/compiler.impure.lisp
View file

@ -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")

2
tests/condition-wait-sigcont.lisp
View file

@ -35,4 +35,4 @@
;; sleep a bit so our runner can kill us
(sleep 10)
(quit)
(exit)

14
tests/core.test.sh
View file

@ -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

2
tests/custom-userinit.lisp
View file

@ -14,4 +14,4 @@
(write-line "/loading custom userinit")
(defun userinit-quit (x)
(sb-ext:quit :unix-status x))
(sb-ext:exit :code x))

2
tests/debug.impure.lisp
View file

@ -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.

2
tests/dynamic-extent.impure.lisp
View file

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

2
tests/enc-cn.impure.lisp
View file

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

2
tests/enc-jpn.impure.lisp
View file

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

2
tests/external-format.impure.lisp
View file

@ -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

18
tests/filesys.test.sh
View file

@ -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)."
#+nil
(need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
(need-matches)
(sb-ext:quit :unix-status $EXIT_LISP_WIN)
(sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 3" $?
cleanup_test_subdirectory
@ -258,19 +258,19 @@ run_sbcl <<EOF
(test "foo:**;*.tmp" "foo/aa.tmp" "far/ab.tmp" "qar/ac.tmp")
(test "foo:foo;*.tmp" "foo/aa.tmp")
(test "c/*/*.bar" "a/z/foo.bar")
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/PATTERNS" $?
# Test whether ENSURE-DIRECTORIES-EXIST can create a directory whose
# name contains a wildcard character (it used to get itself confused
# internally).
run_sbcl --eval '(ensure-directories-exist "foo\\*bar/baz.txt")' --eval '(sb-ext:quit)'
run_sbcl --eval '(ensure-directories-exist "foo\\*bar/baz.txt")' --eval '(sb-ext:exit)'
test -d foo*bar
check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 1" $? \
0 "(directory exists)"
run_sbcl --eval '(ensure-directories-exist "foo\\?bar/baz.txt")' --eval '(sb-ext:quit)'
run_sbcl --eval '(ensure-directories-exist "foo\\?bar/baz.txt")' --eval '(sb-ext:exit)'
test -d foo?bar
check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 2" $? \
0 "(directory exists)"
@ -282,7 +282,7 @@ touch deltest
touch sub/deltest
run_sbcl --eval '(let ((*default-pathname-defaults* (truename "sub")))
(delete-file "deltest")
(sb-ext:quit))'
(sb-ext:exit))'
test -f deltest && test ! -f sub/deltest
check_status_maybe_lose "delete-file via d-p-d" $? \
0 "ok"
@ -335,8 +335,8 @@ run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \
(delete-directory "one" :recursive t))' \
--eval '(handler-case (delete-directory "will_fail")
(file-error ())
(:no-error (x) (sb-ext:quit :unix-status 1)))' \
--eval '(sb-ext:quit)'
(:no-error (x) (sb-ext:exit :code 1)))' \
--eval '(sb-ext:exit)'
check_status_maybe_lose "delete-directory symlink" $? \
0 "ok"
test -L will_fail && test -d dont_delete_me

14
tests/foreign.test.sh
View file

@ -128,7 +128,7 @@ cat > $TEST_FILESTEM.base.lisp <<EOF
;; At least as of sbcl-0.7.0.5, LOAD-SHARED-OBJECT isn't
;; supported on every OS. In that case, there's nothing to test,
;; and we can just fall through to success.
(sb-ext:quit :unix-status 22)))) ; catch that
(sb-ext:exit :code 22)))) ; catch that
(define-alien-routine summish int (x int) (y int))
(define-alien-variable numberish int)
(define-alien-routine nummish int (x int))
@ -256,7 +256,7 @@ cat > $TEST_FILESTEM.test.lisp <<EOF
(assert (typep err 'undefined-alien-error)))
(note "/linkage table ok"))
(sb-ext:quit :unix-status $EXIT_LISP_WIN) ; success convention for Lisp program
(sb-ext:exit :code $EXIT_LISP_WIN) ; success convention for Lisp program
EOF
# Files are now set up; toggle errexit off, since we use a custom exit
@ -266,7 +266,7 @@ set +e
test_compile() {
run_sbcl <<EOF
(progn (load (compile-file "$TEST_FILESTEM.$1.lisp"))
(sb-ext:quit :unix-status $EXIT_LISP_WIN))
(sb-ext:exit :code $EXIT_LISP_WIN))
EOF
check_status_maybe_lose "compile $1" $?
}
@ -287,7 +287,7 @@ test_save() {
run_sbcl --load $TEST_FILESTEM.$1.fasl <<EOF
#+linkage-table (save-lisp-and-die "$TEST_FILESTEM.$1.core")
#-linkage-table nil
(sb-ext:quit :unix-status 22) ; catch this
(sb-ext:exit :code 22) ; catch this
EOF
check_status_maybe_lose "save $1" $? \
0 "(successful save)" 22 "(linkage table not available)"
@ -316,7 +316,7 @@ run_sbcl_with_core $TEST_FILESTEM.fast.core --no-sysinit --no-userinit <<EOF
(multiple-value-bind (val err) (ignore-errors (eval '(bar)))
(assert (not val))
(assert (typep err 'undefined-alien-error)))
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "missing-so" $?
@ -338,7 +338,7 @@ run_sbcl <<EOF
(define-alien-variable b (* foo))
(funcall (compile nil '(lambda () (setq b (addr a)))))
(assert (sb-sys:sap= (alien-sap a) (alien-sap (deref b))))
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "ADDR of a heap-allocated object" $?
@ -354,7 +354,7 @@ run_sbcl <<EOF
(setf (slot *inner* 'var) 40)
(setf (slot *outer* 'two) *inner*)
(assert (= (slot (slot *outer* 'two) 'var) 40))
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "struct offsets" $?

2
tests/full-eval.impure.lisp
View file

@ -12,7 +12,7 @@
;;;; more information.
#-sb-eval
(sb-ext:quit :unix-status 104)
(sb-ext:exit :code 104)
(setf sb-ext:*evaluator-mode* :interpret)

18
tests/interface.test.sh
View file

@ -34,4 +34,22 @@ EOF
;;
esac
run_sbcl --eval '(sb-ext:exit)'
check_status_maybe_lose "simple exit" $? 0 "ok"
run_sbcl --eval '(sb-ext:exit :code 42)'
check_status_maybe_lose "exit with code" $? 42 "ok"
run_sbcl --eval '(progn (defvar *exit-code* 100) (push (lambda () (exit :code (decf *exit-code*))) *exit-hooks*) #+sb-thread (sb-thread:make-thread (lambda () (exit :code 13))) #-sb-thread (exit :code 13))'
check_status_maybe_lose "exit with code" $? 99 "ok"
run_sbcl --eval '(unwind-protect (sb-ext:exit :code 13 :abort t) (sb-ext:exit :code 7 :abort t))'
check_status_maybe_lose "exit with abort" $? 13 "ok"
run_sbcl --eval '(unwind-protect (sb-ext:exit :code 0 :abort t) (sb-ext:exit :code 7 :abort t))'
check_status_maybe_lose "exit with abort and code 0" $? 0 "ok"
run_sbcl --eval '(unwind-protect (sb-ext:exit :code 0 :abort nil) (sb-ext:exit :code 7))'
check_status_maybe_lose "exit with abort and code 0" $? 7 "ok"
exit $EXIT_TEST_WIN

2
tests/kill-non-lisp-thread.impure.lisp
View file

@ -12,7 +12,7 @@
;;;; more information.
#-sb-thread
(sb-ext:quit :unix-status 104)
(sb-ext:exit :code 104)
(use-package :sb-alien)

10
tests/run-tests.lisp
View file

@ -37,9 +37,9 @@
(impure-runner (impure-cload-files) #'cload-test)
#-win32 (impure-runner (sh-files) #'sh-test)
(report)
(sb-ext:quit :unix-status (if (unexpected-failures)
1
104)))
(sb-ext:exit :code (if (unexpected-failures)
1
104)))
(defun report ()
(terpri)
@ -146,7 +146,7 @@
(skip-file ()
(format t ">>>~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*

10
tests/script.test.sh
View file

@ -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 <<EOF
(setf *standard-output* (make-broadcast-stream))
(close *standard-output*)
(sb-ext:quit :unix-status 3)
(sb-ext:exit :code 3)
EOF
run_sbcl --script $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 <<EOF
(sb-ext:quit :unix-status 3)
EOF
run_sbcl --script $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 <<EOF
(loop (write-line (read-line)))

2
tests/step.impure.lisp
View file

@ -15,7 +15,7 @@
;; No stepper support on some platforms.
#-(or x86 x86-64 ppc sparc mips)
(sb-ext:quit :unix-status 104)
(sb-ext:exit :code 104)
(defun fib (x)
(declare (optimize debug))

8
tests/stream.test.sh
View file

@ -23,8 +23,8 @@ cat > $tmpfilename <<EOF
(with-output-to-string (s)
(loop for byte = (read-byte *standard-input* nil)
while byte do (write-char (code-char byte) s))))
(quit :unix-status $EXIT_LISP_WIN)
(quit :unix-status $EXIT_LOSE))
(exit :code $EXIT_LISP_WIN)
(exit :code $EXIT_LOSE))
EOF
run_sbcl --disable-debugger --load $tmpfilename <<EOF
Bivalent *STANDARD-INPUT*
@ -36,7 +36,7 @@ cat > $tmpfilename <<EOF
(loop for char across "Bivalent *STANDARD-OUTPUT*"
do (write-byte (char-code char) *standard-output*))
(terpri *standard-output*)
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
run_sbcl --disable-debugger --load $tmpfilename > $tmpfilename.out
check_status_maybe_lose bivalent-standard-output $?
@ -52,7 +52,7 @@ cat > $tmpfilename <<EOF
(loop for char across "Bivalent *ERROR-OUTPUT*"
do (write-byte (char-code char) *error-output*))
(terpri *error-output*)
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
run_sbcl --disable-debugger --load $tmpfilename 2> $tmpfilename.out
check_status_maybe_lose bivalent-error-output $?

2
tests/stress-gc.sh
View file

@ -18,7 +18,7 @@ run_sbcl <<EOF
(load *)
(time (stress-gc ${1:-100000} ${2:-3000}))
(format t "~&test completed successfully~%")
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "stress-gc" $?
exit $EXIT_TEST_WIN

2
tests/swap-lispobjs.impure.lisp
View file

@ -14,7 +14,7 @@
(use-package :sb-alien)
#-(or x86 x86-64)
(sb-ext:quit :unix-status 104)
(sb-ext:exit :code 104)
(defun run (program &rest arguments)
(let* ((proc nil)

20
tests/threads.impure.lisp
View file

@ -68,7 +68,7 @@
(throw 'xxx nil))))
(check-deferrables-unblocked-or-lose 0))
#-sb-thread (sb-ext:quit :unix-status 104)
#-sb-thread (sb-ext:exit :code 104)
;;;; Now the real tests...
@ -82,7 +82,7 @@
(check-deferrables-blocked-or-lose 0)
(sb-thread::grab-mutex lock)
(check-deferrables-unblocked-or-lose 0)
(sb-ext:quit)))
(sb-thread:abort-thread)))
(sleep 1)
(sb-thread::release-mutex lock)))
@ -152,11 +152,11 @@
(with-test (:name (:join-thread :nlx :default))
(let ((sym (gensym)))
(assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
(assert (eq sym (join-thread (make-thread (lambda () (sb-thread:abort-thread)))
:default sym)))))
(with-test (:name (:join-thread :nlx :error))
(raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
(raises-error? (join-thread (make-thread (lambda () (sb-thread:abort-thread))))
join-thread-error))
(with-test (:name (:join-thread :multiple-values))
@ -175,7 +175,7 @@
(sb-thread:make-thread (lambda ()
(with-mutex (mutex)
(sb-thread:condition-wait queue mutex))
(sb-ext:quit))))
(sb-thread:abort-thread))))
(let ((start-time (get-internal-run-time)))
(funcall function)
(prog1 (- (get-internal-run-time) start-time)
@ -487,7 +487,7 @@
(interrupt-thread child
(lambda ()
(format t "child pid ~A~%" *current-thread*)
(when quit-p (sb-ext:quit))))
(when quit-p (abort-thread))))
(sleep 1)
child))
@ -698,7 +698,7 @@
(sb-unix::strerror)
reference-errno)
(force-output)
(sb-ext:quit :unix-status 1)))))))
(abort-thread)))))))
;; (nanosleep -1 0) does not fail on FreeBSD
(with-test (:name (:exercising-concurrent-syscalls))
@ -725,13 +725,13 @@
(format t "~&errno test done~%")
(with-test (:name (:terminate-thread-restart))
(with-test (:name :all-threads-have-abort-restart)
(loop repeat 100 do
(let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
(sb-thread:interrupt-thread
thread
(lambda ()
(assert (find-restart 'sb-thread:terminate-thread)))))))
(assert (find-restart 'abort)))))))
(sb-ext:gc :full t)
@ -1166,7 +1166,7 @@
(unless (zerop n)
(setf ok nil)
(format t "N != 0 (~A)~%" n)
(sb-ext:quit)))))))))
(abort-thread)))))))))
(wait-for-threads threads)
(assert ok)))

31
tests/threads.pure.lisp
View file

@ -547,3 +547,34 @@
(signal-semaphore sem)
(try-semaphore sem 1 note)
(assert (semaphore-notification-status note))))
(with-test (:name (:return-from-thread :normal-thread))
(let* ((thread (make-thread (lambda ()
(return-from-thread (values 1 2 3))
:foo)))
(values (multiple-value-list (join-thread thread))))
(unless (equal (list 1 2 3) values)
(error "got ~S, wanted (1 2 3)" values))))
(with-test (:name (:return-from-thread :main-thread))
(assert (main-thread-p))
(assert (eq :oops
(handler-case
(return-from-thread t)
(thread-error ()
:oops)))))
(with-test (:name (:abort-thread :normal-thread))
(let ((thread (make-thread (lambda ()
(abort-thread)
:foo))))
(assert (eq :aborted! (join-thread thread :default :aborted!)))))
(with-test (:name (:abort-thread :main-thread))
(assert (main-thread-p))
(assert (eq :oops
(handler-case
(abort-thread)
(thread-error ()
:oops)))))

9
tests/threads.test.sh
View file

@ -14,6 +14,15 @@
. ./subr.sh
use_test_subdirectory
run_sbcl --eval '(sb-thread:return-from-thread t :allow-exit t)'
check_status_maybe_lose "return from main thread" $? 0 "ok"
run_sbcl --eval '(sb-thread:abort-thread :allow-exit t)'
check_status_maybe_lose "abort main thread" $? 1 "ok"
run_sbcl --eval '#+sb-thread (sb-thread:make-thread (lambda () (sb-ext:exit :code 77))) #-sb-thread (sb-ext:exit :code 77)'
check_status_maybe_lose "exit from normal thread" $? 77 "ok"
flag="condition-wait-sigcont.tmp"
touch $flag

4
tests/undefined-classoid-bug.test.sh
View file

@ -16,12 +16,12 @@ run_sbcl <<EOF
(let ((files (list $FILES)))
(mapc #'load files)
(mapc #'compile-file files))
(quit :unix-status 52)
(exit :code 52)
EOF
run_sbcl <<EOF
(mapc #'load (list $FASLS))
(quit :unix-status $EXIT_LISP_WIN)
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose undefined-classoid-bug $?

2
tests/unwind-to-frame-and-call.impure.lisp
View file

@ -14,7 +14,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))
(declaim (optimize debug))

2
tests/win32-foreign-stack-unwind.impure.lisp
View file

@ -11,7 +11,7 @@
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
#-win32 (quit :unix-status 104) ;; This is extremely win32-specific.
#-win32 (exit :code 104) ;; This is extremely win32-specific.
(use-package :sb-alien)

3
tools-for-build/ldso-stubs.lisp
View file

@ -191,7 +191,8 @@ ldso_stub__ ## fct: ; \\
.size ldso_stub__ ## fct,.-ldso_stub__ ## fct ;"))
(defvar *stubs* (append
'("accept"
'("_exit"
"accept"
"access"
"acos"
"acosh"