diff --git a/NEWS b/NEWS index 897c552d3..86d825010 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.56: + * enhancement: redesigned protocol for quitting SBCL. SB-EXT:EXIT is the new + main entry point, SB-EXT:QUIT is deprecated. + * enhancement: additions to the SB-THREAD API: RETURN-FROM-THREAD, + ABORT-THREAD, MAIN-THREAD-P, and MAIN-THREAD. * enhancement: FASL loading no longer grabs the world-lock. * enhancement: GENCGC reclaims space more aggressively when objects being allocated are a large fraction of the total available heap space. @@ -37,6 +41,8 @@ changes relative to sbcl-1.0.56: * bug fix: better input error reporting for COMPILE-FILE. (lp#493380) * bug fix: default size of non-nursery generations has been shrunk on GENCGC, allowing faster release of memory back to the OS. (lp#991293) + * bug fix: WITH-DEADLINE (:SECONDS NIL :OVERRIDE T) now drops any + existing deadline for the dynamic scope of its body. * documentation: ** improved docstrings: REPLACE (lp#965592) diff --git a/contrib/asdf-module.mk b/contrib/asdf-module.mk index 873606bca..ddce36b4b 100644 --- a/contrib/asdf-module.mk +++ b/contrib/asdf-module.mk @@ -27,7 +27,7 @@ export CC SBCL EXTRA_CFLAGS EXTRA_LDFLAGS all: $(EXTRA_ALL_TARGETS) $(MAKE) -C ../asdf - $(SBCL) --eval '(defvar *system* "$(SYSTEM)")' --load ../asdf-stub.lisp --eval '(quit)' + $(SBCL) --eval '(defvar *system* "$(SYSTEM)")' --load ../asdf-stub.lisp --eval '(exit)' test: all echo "(asdf:operate (quote asdf:load-op) :$(SYSTEM))" \ diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index db3c251d2..7997a79cb 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -328,7 +328,7 @@ (map nil #'sb-thread:destroy-thread threads) (sleep 0.2)) (return-from exit-cmd))))) - (sb-ext:quit :unix-status status) + (sb-ext:exit :code status) (values)) (defun package-cmd (&optional pkg) @@ -783,7 +783,7 @@ ;; command (cond ((eq user-cmd *eof-cmd*) (when *exit-on-eof* - (sb-ext:quit)) + (sb-ext:exit)) (format *output* "EOF~%") t) ((eq user-cmd *null-cmd*) diff --git a/contrib/sb-concurrency/tests/test-gate.lisp b/contrib/sb-concurrency/tests/test-gate.lisp index 9575d3c79..64aa86455 100644 --- a/contrib/sb-concurrency/tests/test-gate.lisp +++ b/contrib/sb-concurrency/tests/test-gate.lisp @@ -39,7 +39,7 @@ (interrupt-thread (car threads) (lambda () (unwind-protect (when (gate-open-p gate) - (sb-ext:quit)) + (abort-thread)) (open-gate int-gate)))) (wait-on-gate int-gate) (assert (every #'null marks)) diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp index c37bd89c8..77740e009 100644 --- a/contrib/sb-executable/sb-executable.lisp +++ b/contrib/sb-executable/sb-executable.lisp @@ -32,7 +32,7 @@ strategy." (defvar *exec-header* "#!/bin/sh -- -exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (quit))\" --end-toplevel-options ${1+\"$@\"} +exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (exit))\" --end-toplevel-options ${1+\"$@\"} ") (defun make-executable (output-file fasls diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 13bb23d96..c73f2d1af 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -461,13 +461,13 @@ (progn (multiple-value-bind (nope error) (ignore-errors (sb-posix:fcntl f sb-posix:f-setlk flock)) - (sb-ext:quit - :unix-status + (sb-ext:exit + :code (cond ((not (null nope)) 1) ((= (sb-posix:syscall-errno error) sb-posix:eagain) 42) (t 86)) - :recklessly-p t #| don't delete the file |#))) + :abort t #| don't delete the file |#))) (progn (setf kid-status (sb-posix:wexitstatus @@ -495,12 +495,12 @@ (pid (sb-posix:fork))) (if (zerop pid) (let ((r (sb-posix:fcntl f sb-posix:f-getlk flock))) - (sb-ext:quit - :unix-status + (sb-ext:exit + :code (cond ((not (zerop r)) 1) ((= (sb-posix:flock-pid flock) ppid) 42) (t 86)) - :recklessly-p t #| don't delete the file |#)) + :abort t #| don't delete the file |#)) (progn (setf kid-status (sb-posix:wexitstatus diff --git a/doc/manual/create-contrib-doc-list.lisp b/doc/manual/create-contrib-doc-list.lisp index 2d4db6ba8..0518813c8 100644 --- a/doc/manual/create-contrib-doc-list.lisp +++ b/doc/manual/create-contrib-doc-list.lisp @@ -39,4 +39,4 @@ :name (pathname-name texi-file) :type (pathname-type texi-file))))))) -(sb-ext:quit) +(sb-ext:exit) diff --git a/doc/manual/make-tempfiles.sh b/doc/manual/make-tempfiles.sh index c212d74cc..aac4bb121 100644 --- a/doc/manual/make-tempfiles.sh +++ b/doc/manual/make-tempfiles.sh @@ -36,7 +36,7 @@ fi SBCL="$SBCLRUNTIME --noinform --no-sysinit --no-userinit --noprint --disable-debugger" # extract version and date -VERSION=`$SBCL --eval '(write-line (lisp-implementation-version))' --eval '(sb-ext:quit)'` +VERSION=`$SBCL --eval '(write-line (lisp-implementation-version))' --eval '(sb-ext:exit)'` MONTH=`date "+%Y-%m"` sed -e "s/@VERSION@/$VERSION/" \ @@ -62,11 +62,11 @@ $SBCL <" + :format-arguments (list values) + :thread self)) + (sb!ext:exit :code 0)) + (t + (throw '%return-from-thread (values-list values)))))) + +(defun abort-thread (&key allow-exit) + "Unwinds from and terminates the current thread abnormally, causing +JOIN-THREAD on current thread to signal an error unless a +default-value is provided. + +If current thread is the main thread of the process (see +MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as +terminating the main thread would terminate the entire process. If +ALLOW-EXIT is true, aborting the main thread is equivalent to calling +SB-EXT:EXIT code 1 and :ABORT NIL. + +Invoking the initial ABORT restart estabilished by MAKE-THREAD is +equivalent to calling ABORT-THREAD in other than main threads. +However, whereas ABORT restart may be rebound, ABORT-THREAD always +unwinds the entire thread. (Behaviour of the initial ABORT restart for +main thread depends on the :TOPLEVEL argument to +SB-EXT:SAVE-LISP-AND-DIE.) + +See also: RETURN-FROM-THREAD and SB-EXT:EXIT." + (let ((self *current-thread*)) + (cond ((main-thread-p self) + (unless allow-exit + (error 'simple-thread-error + :format-control "~@")) + (sb!ext:exit :code 1)) + (t + ;; We /could/ use TOPLEVEL-CATCHER or %END-OF-THE-WORLD as well, but + ;; this seems tidier. Those to are a bit too overloaded already. + (throw '%abort-thread t))))) ;;;; Aliens, low level stuff @@ -1110,6 +1185,13 @@ on this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (/show0 "HANDLING THREAD EXIT") + (when *exit-in-process* + (if (consp *exit-in-process*) + ;; This means we're the main thread, but someone else + ;; requested the exit and exiting with the right code is the + ;; only thing left to do. + (os-exit (car *exit-in-process*) :abort nil) + (%exit))) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -1118,6 +1200,44 @@ on this semaphore, then N of them is woken up." (when *session* (%delete-thread-from-session thread *session*)))) +(defun %exit-other-threads () + ;; Grabbing this lock prevents new threads from + ;; being spawned, and guarantees that *ALL-THREADS* + ;; is up to date. + (with-deadline (:seconds nil :override t) + (grab-mutex *make-thread-lock*) + (let ((timeout sb!ext:*exit-timeout*) + (code *exit-in-process*) + (joinees nil) + (main nil)) + (dolist (thread (list-all-threads)) + (cond ((eq thread *current-thread*)) + ((main-thread-p thread) + (setf main thread)) + (t + (handler-case + (progn + (terminate-thread thread) + (push thread joinees)) + (interrupt-thread-error ()))))) + (dolist (thread (nreverse joinees)) + (join-thread thread :default t :timeout timeout)) + ;; Need to defer till others have joined, because when main + ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would + ;; get the exit code wrong. + (when main + (handler-case + (interrupt-thread + main + (lambda () + (setf *exit-in-process* (list code)) + (throw 'sb!impl::%end-of-the-world t))) + (interrupt-thread-error ())) + ;; Normally this never finishes, as once the main-thread + ;; unwinds we exit with the right code, but if times out + ;; before that happens, we will exit after returning. + (join-thread main :default t :timeout timeout))))) + (defun terminate-session () #!+sb-doc "Kill all threads in session except for this one. Does nothing if current @@ -1223,9 +1343,14 @@ have the foreground next." (defun make-thread (function &key name arguments) #!+sb-doc "Create a new thread of NAME that runs FUNCTION with the argument -list designator provided (defaults to no argument). When the function -returns the thread exits. The return values of FUNCTION are kept -around and can be retrieved by JOIN-THREAD." +list designator provided (defaults to no argument). Thread exits when +the function returns. The return values of FUNCTION are kept around +and can be retrieved by JOIN-THREAD. + +Invoking the initial ABORT restart estabilished by MAKE-THREAD +terminates the thread. + +See also: RETURN-FROM-THREAD, ABORT-THREAD." #!-sb-thread (declare (ignore function name arguments)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (assert (or (atom arguments) @@ -1234,116 +1359,118 @@ around and can be retrieved by JOIN-THREAD." "Argument passed to ~S, ~S, is an improper list." 'make-thread arguments) #!+sb-thread - (let* ((thread (%make-thread :name name)) - (setup-sem (make-semaphore :name "Thread setup semaphore")) - (real-function (coerce function 'function)) - (arguments (if (listp arguments) - arguments - (list arguments))) - (initial-function - (named-lambda initial-thread-function () - ;; In time we'll move some of the binding presently done in C - ;; here too. - ;; - ;; KLUDGE: Here we have a magic list of variables that are - ;; not thread-safe for one reason or another. As people - ;; report problems with the thread safety of certain - ;; variables, (e.g. "*print-case* in multiple threads - ;; broken", sbcl-devel 2006-07-14), we add a few more - ;; bindings here. The Right Thing is probably some variant - ;; of Allegro's *cl-default-special-bindings*, as that is at - ;; least accessible to users to secure their own libraries. - ;; --njf, 2006-07-15 - ;; - ;; As it is, this lambda must not cons until we are ready - ;; to run GC. Be very careful. - (let* ((*current-thread* thread) - (*restart-clusters* nil) - (*handler-clusters* (sb!kernel::initial-handler-clusters)) - (*condition-restarts* nil) - (sb!impl::*deadline* nil) - (sb!impl::*deadline-seconds* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (sb!impl::*internal-symbol-output-fun* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - ;; Binding from C - (setf sb!vm:*alloc-signal* *default-alloc-signal*) - (setf (thread-os-thread thread) (current-thread-os-thread)) - (with-mutex ((thread-result-lock thread)) - (with-all-threads-lock - (push thread *all-threads*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (setf (thread-%alive-p thread) t) - (signal-semaphore setup-sem) - ;; can't use handling-end-of-the-world, because that flushes - ;; output streams, and we don't necessarily have any (or we - ;; could be sharing them) - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil - "~~@" - *current-thread*)) - (without-interrupts - (unwind-protect - (with-local-interrupts - ;; Now that most things have a chance - ;; to work properly without messing up - ;; other threads, it's time to enable - ;; signals. - (sb!unix::unblock-deferrable-signals) - (setf (thread-result thread) - (cons t - (multiple-value-list - (apply real-function arguments)))) - ;; Try to block deferrables. An - ;; interrupt may unwind it, but for a - ;; normal exit it prevents interrupt - ;; loss. - (block-deferrable-signals)) - ;; We're going down, can't handle interrupts - ;; sanely anymore. GC remains enabled. - (block-deferrable-signals) - ;; We don't want to run interrupts in a dead - ;; thread when we leave WITHOUT-INTERRUPTS. - ;; This potentially causes important - ;; interupts to be lost: SIGINT comes to - ;; mind. - (setq *interrupt-pending* nil) - (handle-thread-exit thread)))))))) - (values)))) - ;; If the starting thread is stopped for gc before it signals the - ;; semaphore then we'd be stuck. - (assert (not *gc-inhibit*)) - ;; Keep INITIAL-FUNCTION pinned until the child thread is - ;; initialized properly. Wrap the whole thing in - ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another - ;; thread. - (without-interrupts - (with-pinned-objects (initial-function) - (let ((os-thread - (%create-thread - (get-lisp-obj-address initial-function)))) - (when (zerop os-thread) - (error "Can't create a new thread")) - (wait-on-semaphore setup-sem) - thread))))) + (tagbody + (with-mutex (*make-thread-lock*) + (let* ((thread (%make-thread :name name)) + (setup-sem (make-semaphore :name "Thread setup semaphore")) + (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) + (initial-function + (named-lambda initial-thread-function () + ;; In time we'll move some of the binding presently done in C + ;; here too. + ;; + ;; KLUDGE: Here we have a magic list of variables that are + ;; not thread-safe for one reason or another. As people + ;; report problems with the thread safety of certain + ;; variables, (e.g. "*print-case* in multiple threads + ;; broken", sbcl-devel 2006-07-14), we add a few more + ;; bindings here. The Right Thing is probably some variant + ;; of Allegro's *cl-default-special-bindings*, as that is at + ;; least accessible to users to secure their own libraries. + ;; --njf, 2006-07-15 + ;; + ;; As it is, this lambda must not cons until we are ready + ;; to run GC. Be very careful. + (let* ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) + (*condition-restarts* nil) + (*exit-in-process* nil) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) + (with-mutex ((thread-result-lock thread)) + (with-all-threads-lock + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (signal-semaphore setup-sem) + ;; Using handling-end-of-the-world would be a bit tricky + ;; due to other catches and interrupts, so we essentially + ;; re-implement it here. Once and only once more. + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (catch '%abort-thread + (with-simple-restart + (abort "~@" *current-thread*) + (without-interrupts + (unwind-protect + (with-local-interrupts + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (cons t + (multiple-value-list + (unwind-protect + (catch '%return-from-thread + (apply real-function arguments)) + (when *exit-in-process* + (sb!impl::call-exit-hooks))))))) + ;; We're going down, can't handle interrupts + ;; sanely anymore. GC remains enabled. + (block-deferrable-signals) + ;; We don't want to run interrupts in a dead + ;; thread when we leave WITHOUT-INTERRUPTS. + ;; This potentially causes important + ;; interupts to be lost: SIGINT comes to + ;; mind. + (setq *interrupt-pending* nil) + (handle-thread-exit thread))))))))) + (values)))) + ;; If the starting thread is stopped for gc before it signals the + ;; semaphore then we'd be stuck. + (assert (not *gc-inhibit*)) + ;; Keep INITIAL-FUNCTION pinned until the child thread is + ;; initialized properly. Wrap the whole thing in + ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another + ;; thread. + (without-interrupts + (with-pinned-objects (initial-function) + (let ((os-thread + (%create-thread + (get-lisp-obj-address initial-function)))) + (when (zerop os-thread) + (go :cant-spawn)) + (wait-on-semaphore setup-sem) + (return-from make-thread thread)))))) + :cant-spawn + (error "Could not create a new thread."))) (defun join-thread (thread &key (default nil defaultp) timeout) #!+sb-doc - "Suspend current thread until THREAD exits. Return the result values of the -thread function. + "Suspend current thread until THREAD exits. Return the result values +of the thread function. -If the thread does not exit normally within TIMEOUT seconds return DEFAULT if -given, or else signal JOIN-THREAD-ERROR. +If the thread does not exit normally within TIMEOUT seconds return +DEFAULT if given, or else signal JOIN-THREAD-ERROR. -NOTE: Return convention in case of a timeout is exprimental and subject to -change." +Trying to join the main thread will cause JOIN-THREAD to block until +TIMEOUT occurs or the process exits: when main thread exits, the +entire process exits. + +NOTE: Return convention in case of a timeout is exprimental and +subject to change." (let ((lock (thread-result-lock thread)) (got-it nil) (problem :timeout)) @@ -1468,11 +1595,11 @@ Short version: be careful out there." (defun terminate-thread (thread) #!+sb-doc - "Terminate the thread identified by THREAD, by interrupting it and causing -it to call SB-EXT:QUIT. + "Terminate the thread identified by THREAD, by interrupting it and +causing it to call SB-EXT:ABORT-THREAD with :ALLOW-EXIT T. -The unwind caused by TERMINATE-THREAD is asynchronous, meaning that eg. thread -executing +The unwind caused by TERMINATE-THREAD is asynchronous, meaning that +eg. thread executing (let (foo) (unwind-protect @@ -1485,12 +1612,12 @@ executing ;; to be dropped. (release-foo foo)))) -might miss calling RELEASE-FOO despite GET-FOO having returned true if the -interrupt occurs inside the cleanup clause, eg. during execution of -RELEASE-FOO. +might miss calling RELEASE-FOO despite GET-FOO having returned true if +the interrupt occurs inside the cleanup clause, eg. during execution +of RELEASE-FOO. -Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need to use -WITHOUT-INTERRUPTS: +Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need +to use WITHOUT-INTERRUPTS: (let (foo) (sb-sys:without-interrupts @@ -1505,7 +1632,7 @@ WITHOUT-INTERRUPTS: Since most libraries using UNWIND-PROTECT do not do this, you should never assume that unknown code can safely be terminated using TERMINATE-THREAD." - (interrupt-thread thread 'sb!ext:quit)) + (interrupt-thread thread (lambda () (abort-thread :allow-exit t)))) (define-alien-routine "thread_yield" int) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 73849728e..9fa818930 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -75,29 +75,45 @@ been specified on the command-line.") ;;; by QUIT) is caught and any final processing and return codes are ;;; handled appropriately. (defmacro handling-end-of-the-world (&body body) - (with-unique-names (caught) - `(without-interrupts - (let ((,caught - (catch '%end-of-the-world - (unwind-protect - (with-local-interrupts ,@body (quit)) - (handler-case - (with-local-interrupts - (call-hooks "exit" *exit-hooks* :on-error :warn)) - (serious-condition () - 1)))))) - ;; If user called QUIT and exit hooks were OK, the status is what it - ;; is -- even eg. streams cannot be flushed anymore. Even if - ;; something goes wrong now, we still report what was asked. We still - ;; want to have %END-OF-THE-WORLD visible, though. - (catch '%end-of-the-world - (handler-case - (unwind-protect - (progn - (flush-standard-output-streams) - (sb!thread::terminate-session)) - (sb!unix:unix-exit ,caught)) - (serious-condition ()))))))) + `(without-interrupts + (catch '%end-of-the-world + (unwind-protect + (with-local-interrupts + (unwind-protect + (progn ,@body) + (call-exit-hooks))) + (%exit))))) + +(defvar *exit-lock*) +(defvar *exit-in-process* nil) +(declaim (type (or null real) *exit-timeout*)) +(defvar *exit-timeout* 60 + "Default amount of seconds, if any, EXIT should wait for other +threads to finish after terminating them. Default value is 60. NIL +means to wait indefinitely.") + +(defun os-exit-handler (condition) + (declare (ignore condition)) + (os-exit *exit-in-process* :abort t)) + +(defvar *exit-error-handler* #'os-exit-handler) + +(defun call-exit-hooks () + (unless *exit-in-process* + (setf *exit-in-process* 0)) + (handler-bind ((serious-condition *exit-error-handler*)) + (call-hooks "exit" *exit-hooks* :on-error :warn))) + +(defun %exit () + ;; If anything goes wrong, we will exit immediately and forcibly. + (handler-bind ((serious-condition *exit-error-handler*)) + (let (ok) + (unwind-protect + (progn + (flush-standard-output-streams) + (sb!thread::%exit-other-threads) + (setf ok t)) + (os-exit *exit-in-process* :abort (not ok)))))) ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* @@ -315,7 +331,7 @@ any non-negative real number." value) (load (native-pathname value)))) (:quit - (quit)))) + (exit)))) (flush-standard-output-streams))) (with-simple-restart (abort "Skip rest of --eval and --load options.") (dolist (option options) @@ -330,7 +346,7 @@ any non-negative real number." ;; Shell-style. (when (member (stream-error-stream e) (list *stdout* *stdin* *stderr*)) - (quit))))) + (exit))))) ;; Let's not use the *TTY* for scripts, ok? Also, normally we use ;; synonym streams, but in order to have the broken pipe/eof error ;; handling right we want to bind them for scripts. @@ -347,7 +363,7 @@ any non-negative real number." (sb!fasl::maybe-skip-shebang-line f) (load-script f)))))) -;; Errors while processing the command line cause the system to QUIT, +;; Errors while processing the command line cause the system to EXIT, ;; instead of trying to go into the Lisp debugger, because trying to ;; go into the Lisp debugger would get into various annoying issues of ;; where we should go after the user tries to return from the @@ -357,7 +373,7 @@ any non-negative real number." "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%" control-string args) - (quit :unix-status 1)) + (exit :code 1)) ;;; the default system top level function (defun toplevel-init () @@ -519,11 +535,11 @@ any non-negative real number." s)) (/show0 "CONTINUEing from pre-REPL RESTART-CASE") (values)) ; (no-op, just fall through) - (quit () - :report "Quit SBCL (calling #'QUIT, killing the process)." + (exit () + :report "Exit SBCL (calling #'EXIT, killing the process)." :test (lambda (c) (declare (ignore c)) (not script)) - (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") - (quit :unix-status 1)))) + (/show0 "falling through to EXIT from pre-REPL RESTART-CASE") + (exit :code 1)))) ;; one more time for good measure, in case we fell out of the ;; RESTART-CASE above before one of the flushes in the ordinary @@ -600,7 +616,7 @@ that provides the REPL for the system. Assumes that *STANDARD-INPUT* and (let* ((eof-marker (cons nil nil)) (form (read in nil eof-marker))) (if (eq form eof-marker) - (quit) + (exit) form))) (defun repl-fun (noprint) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 248f72e1c..2373feb0d 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -427,9 +427,14 @@ corresponds to NAME, or NIL if there is none." ;;; Terminate the current process with an optional error code. If ;;; successful, the call doesn't return. If unsuccessful, the call ;;; returns NIL and an error number. -(defun unix-exit (&optional (code 0)) - (declare (type (signed-byte 32) code)) - (void-syscall ("exit" int) code)) +(deftype exit-code () + `(signed-byte 32)) +(defun os-exit (code &key abort) + (unless (typep code 'exit-code) + (setf code (if abort 1 0))) + (if abort + (void-syscall ("_exit" int) code) + (void-syscall ("exit" int) code))) ;;; Return the process id of the current process. (define-alien-routine ("getpid" unix-getpid) int) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 22a2eaeae..d08bb700d 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -15,7 +15,7 @@ ;;; callbacks only on a few platforms #-alien-callbacks -(quit :unix-status 104) +(exit :code 104) ;;; simple callback for a function diff --git a/tests/clos-cache.impure.lisp b/tests/clos-cache.impure.lisp index c3e07d62c..46e1a1abe 100644 --- a/tests/clos-cache.impure.lisp +++ b/tests/clos-cache.impure.lisp @@ -72,7 +72,7 @@ (error (e) (note "~&Error in cache test in ~S:~%~A~%...aborting" sb-thread:*current-thread* e) - (sb-ext:quit :unix-status 1))) + (sb-ext:exit :code 1))) (note "/~S done" sb-thread:*current-thread*)) #+sb-thread diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index bf8e74b86..b5d651224 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -16,7 +16,7 @@ ;;;; more information. (when (eq sb-ext:*evaluator-mode* :interpret) - (sb-ext:quit :unix-status 104)) + (sb-ext:exit :code 104)) (load "test-util.lisp") (load "compiler-test-util.lisp") diff --git a/tests/condition-wait-sigcont.lisp b/tests/condition-wait-sigcont.lisp index 04fd5cdcd..c4c431244 100644 --- a/tests/condition-wait-sigcont.lisp +++ b/tests/condition-wait-sigcont.lisp @@ -35,4 +35,4 @@ ;; sleep a bit so our runner can kill us (sleep 10) -(quit) +(exit) diff --git a/tests/core.test.sh b/tests/core.test.sh index 9ffec8c35..02d3d4726 100644 --- a/tests/core.test.sh +++ b/tests/core.test.sh @@ -39,7 +39,7 @@ run_sbcl < "$tmpoutput" --no-userinit --no-sysinit --noprint < $TEST_FILESTEM.base.lisp < $TEST_FILESTEM.test.lisp <>>~a<<<~%" test-util::*failures*))) (test-util:report-test-status) - (sb-ext:quit :unix-status 104))))) + (sb-ext:exit :code 104))))) (defun impure-runner (files test-fun) (format t "// Running impure tests (~a)~%" test-fun) @@ -211,7 +211,7 @@ :output *error-output*))) (let ((*failures* nil)) (test-util:report-test-status)) - (sb-ext:quit :unix-status (process-exit-code process)))) + (sb-ext:exit :code (process-exit-code process)))) (defun accept-test-file (file) (if *accept-files* diff --git a/tests/script.test.sh b/tests/script.test.sh index 87a2e0833..33483bad6 100644 --- a/tests/script.test.sh +++ b/tests/script.test.sh @@ -21,9 +21,9 @@ tmpscript=$TEST_FILESTEM.lisp-script tmpout=$TEST_FILESTEM.lisp-out tmperr=$TEST_FILESTEM.lisp-err -echo '(quit :unix-status 7)' > $tmpscript +echo '(exit :code 7)' > $tmpscript run_sbcl --script $tmpscript -check_status_maybe_lose "--script exit status from QUIT" $? 7 "(quit status good)" +check_status_maybe_lose "--script exit status from EXIT" $? 7 "(status good)" echo '(error "oops")' > $tmpscript run_sbcl --script $tmpscript 1> $tmpout 2> $tmperr @@ -40,7 +40,7 @@ check_status_maybe_lose "--script exit status from normal exit" $? 0 "(everythin cat > $tmpscript </dev/null check_status_maybe_lose "--script exit status from QUIT when standard-output closed" $? 3 "(as given)" @@ -61,9 +61,9 @@ cat > $tmpscript </dev/null -check_status_maybe_lose "--script exit status from QUIT when stdout closed" $? 3 "(as given)" +check_status_maybe_lose "--script exit status from EXIT when stdout closed" $? 3 "(as given)" run_sbcl --load $tmpscript >/dev/null -check_status_maybe_lose "--load exit status from QUIT when stdout closed" $? 3 "(as given)" +check_status_maybe_lose "--load exit status from EXIT when stdout closed" $? 3 "(as given)" cat > $tmpscript < $tmpfilename < $tmpfilename < $tmpfilename.out check_status_maybe_lose bivalent-standard-output $? @@ -52,7 +52,7 @@ cat > $tmpfilename < $tmpfilename.out check_status_maybe_lose bivalent-error-output $? diff --git a/tests/stress-gc.sh b/tests/stress-gc.sh index 36ef3364c..386e903de 100644 --- a/tests/stress-gc.sh +++ b/tests/stress-gc.sh @@ -18,7 +18,7 @@ run_sbcl <