From f486d6af546bace9f7442d37cb7ff245d144aa81 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 28 May 2011 15:23:28 +0000 Subject: [PATCH] 1.0.48.29: better end-of-the-world handling * Implicit QUIT. * Make sure we have %END-OF-THE-WORLD visible while doing cleanups. * Handle errors from cleanups. * Disable interrupts in places where the environment might now be up to handling them yet/anymore. * If user calls QUIT, and exit hooks run without serious trouble, report the exit status requested even if there is trouble later flushing streams, etc. * Also make SAVE-LISP-AND-DIE signal an error if SAVE returns. (When there is eg. a file with the desired name but insufficient permissions.) --- NEWS | 1 + src/code/save.lisp | 10 ++++++---- src/code/toplevel.lisp | 35 +++++++++++++++++++++++------------ tests/debug.impure.lisp | 9 ++++----- tests/script.test.sh | 13 ++++++++++++- tests/smoke.impure.lisp | 6 ++++++ version.lisp-expr | 2 +- 7 files changed, 53 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index 319822c..4615575 100644 --- a/NEWS +++ b/NEWS @@ -36,6 +36,7 @@ changes relative to sbcl-1.0.48: 1.0.43.57) * bug fix: TRULY-THE forms are now macroexpandable and setf-expandable. (lp#771673) + * bug fix: spurious errors during QUIT when standard streams were closed. changes in sbcl-1.0.48 relative to sbcl-1.0.47: * incompatible change: SB!KERNEL:INSTANCE-LAMBDA, deprecated for over five diff --git a/src/code/save.lisp b/src/code/save.lisp index 1ddf475..ed323a7 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -126,9 +126,7 @@ sufficiently motivated to do lengthy fixes." (handling-end-of-the-world (reinit) #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub) - (progn - (funcall toplevel) - (sb!ext:quit)))) + (funcall toplevel))) (foreign-bool (value) (if value 1 0)) (save-core (gc) @@ -162,7 +160,11 @@ sufficiently motivated to do lengthy fixes." ;; Compact the environment even though we're skipping the ;; other purification stages. (sb!kernel::compact-environment-aux "Auxiliary" 200) - (save-core t))))) + (save-core t))) + ;; Something went very wrong -- reinitialize to have a prayer + ;; of being able to report the error. + (reinit) + (error "Could not save core."))) (defun deinit () (call-hooks "save" *save-hooks*) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 7c84ba6..e4cd7be 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -75,16 +75,28 @@ command-line.") ;;; handled appropriately. (defmacro handling-end-of-the-world (&body body) (with-unique-names (caught) - `(let ((,caught (catch '%end-of-the-world - (/show0 "inside CATCH '%END-OF-THE-WORLD") - (unwind-protect - (progn ,@body) - (call-hooks "exit" *exit-hooks*))))) - (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output") - (flush-standard-output-streams) - (sb!thread::terminate-session) - (/show0 "calling UNIX-EXIT") - (sb!unix:unix-exit ,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 ()))))))) ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* @@ -289,8 +301,7 @@ any non-negative real number." ;; Scripts don't need to be stylish or fast, but silence is usually a ;; desirable quality... (handler-bind (((or style-warning compiler-note) #'muffle-warning)) - (load f :verbose nil :print nil)) - (quit))))) + (load f :verbose nil :print nil)))))) ;; Errors while processing the command line cause the system to QUIT, ;; instead of trying to go into the Lisp debugger, because trying to diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 7323377..620d032 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -121,11 +121,10 @@ ;; any way. (Depends on running in the main ;; thread.) FIXME: On Windows we get two ;; extra foreign frames below regular frames. - (let ((end (last backtrace #-win32 2 #+win32 4))) - (unless (equal (caar end) - 'sb-impl::toplevel-init) - (print (list :backtrace-stunted (caar end))) - (setf result nil))) + (unless (find '(sb-impl::toplevel-init) backtrace + :test #'equal) + (print (list :backtrace-stunted backtrace)) + (setf result nil)) (return-from outer-handler))))) (funcall test-function))) result))) diff --git a/tests/script.test.sh b/tests/script.test.sh index a9ce19a..89693ff 100644 --- a/tests/script.test.sh +++ b/tests/script.test.sh @@ -24,13 +24,24 @@ run_sbcl --script $tmpscript check_status_maybe_lose "--script exit status from QUIT" $? 7 "(quit status good)" echo '(error "oops")' > $tmpscript -run_sbcl --script $tmpscript +run_sbcl --script $tmpscript 2> /dev/null check_status_maybe_lose "--script exit status from ERROR" $? 1 "(error implies 1)" echo 'nil'> $tmpscript run_sbcl --script $tmpscript check_status_maybe_lose "--script exit status from normal exit" $? 0 "(everything ok)" +cat > $tmpscript <