;;;; -*- 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.
* 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)
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))" \
(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)
;; 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*)
(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))
(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
(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
(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
:name (pathname-name texi-file)
:type (pathname-type texi-file)))))))
-(sb-ext:quit)
+(sb-ext:exit)
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/" \
(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
* (+ 2 2)
4
-* (quit)
+* (exit)
$
@end smallexample
@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
@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
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
* (+ 1 2 3)
6
- * (quit)
+ * (exit)
\fR
Most people like to run SBCL as a subprocess under Emacs. The Emacs
: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" \
;; 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*"
"*INVOKE-DEBUGGER-HOOK*"
;; miscellaneous useful supported extensions
- "QUIT"
+ "QUIT" "EXIT"
"*ED-FUNCTIONS*"
"*MODULE-PROVIDER-FUNCTIONS*"
"WITH-TIMEOUT" "TIMEOUT"
"%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"
"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"
;; SB!KERNEL.)
"%PRIMITIVE"
"%STANDARD-CHAR-P"
+ "*EXIT-ERROR-HANDLER*"
+ "*EXIT-IN-PROCESS*"
"*ALLOW-WITH-INTERRUPTS*"
"*INTERRUPTS-ENABLED*"
"*INTERRUPT-PENDING*"
"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"
"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"
"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"
(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."))
\f
;;;; initialization functions
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))))
(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
(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)
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
(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
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
#!-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)))))
\f
;;;; Aliens, low level stuff
#!+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)
(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
(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)
"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.
+Trying to join the main thread will cause JOIN-THREAD to block until
+TIMEOUT occurs or the process exits: when main thread exits, the
+entire process exits.
-NOTE: Return convention in case of a timeout is exprimental and subject to
-change."
+NOTE: Return convention in case of a timeout is exprimental and
+subject to change."
(let ((lock (thread-result-lock thread))
(got-it nil)
(problem :timeout))
(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
;; 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
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)
;;; 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))))))
\f
;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
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)
;; 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.
(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
"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 ()
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
(let* ((eof-marker (cons nil nil))
(form (read in nil eof-marker)))
(if (eq form eof-marker)
- (quit)
+ (exit)
form)))
(defun repl-fun (noprint)
;;; 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)
;;; callbacks only on a few platforms
#-alien-callbacks
-(quit :unix-status 104)
+(exit :code 104)
;;; simple callback for a function
(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
;;;; 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")
;; sleep a bit so our runner can kill us
(sleep 10)
-(quit)
+(exit)
(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)"
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
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
(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
(write-line "/loading custom userinit")
(defun userinit-quit (x)
- (sb-ext:quit :unix-status x))
+ (sb-ext:exit :code x))
;;; 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))
\f
;;;; Check that we get debug arglists right.
;;;; 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)
;;; -*- 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)
;; -*- 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)
#-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
(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" $?
(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
#+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
(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)"
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"
(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
;; 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))
(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
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" $?
}
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)"
(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" $?
(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" $?
(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" $?
;;;; more information.
#-sb-eval
-(sb-ext:quit :unix-status 104)
+(sb-ext:exit :code 104)
(setf sb-ext:*evaluator-mode* :interpret)
;;
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
;;;; more information.
#-sb-thread
-(sb-ext:quit :unix-status 104)
+(sb-ext:exit :code 104)
(use-package :sb-alien)
(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)
(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)
: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*
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
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)"
(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)))
;; 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))
(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*
(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 $?
(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 $?
(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
\ No newline at end of file
(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)
(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...
(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)))
(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))
(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)
(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))
(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))
(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)
(unless (zerop n)
(setf ok nil)
(format t "N != 0 (~A)~%" n)
- (sb-ext:quit)))))))))
+ (abort-thread)))))))))
(wait-for-threads threads)
(assert ok)))
(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)))))
+
. ./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
(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 $?
;;; 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))
;;;; 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)
.size ldso_stub__ ## fct,.-ldso_stub__ ## fct ;"))
(defvar *stubs* (append
- '("accept"
+ '("_exit"
+ "accept"
"access"
"acos"
"acosh"
projects / sbcl.git / commitdiff