From: Nikodemus S. <de...@us...> - 2008-01-10 11:32:52
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv26060/src/code Modified Files: cold-init.lisp gc.lisp late-extensions.lisp save.lisp target-extensions.lisp toplevel.lisp Log Message: 1.0.13.20: added SB-EXT:*EXIT-HOOKS* * Also document *INIT-HOOKS* and *SAVE-HOOKS*. * Trailing whitespace cleanup in start-stop.texinfo. Index: cold-init.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v retrieving revision 1.74 retrieving revision 1.75 diff -u -d -r1.74 -r1.75 --- cold-init.lisp 30 Sep 2007 23:18:50 -0000 1.74 +++ cold-init.lisp 10 Jan 2008 11:32:48 -0000 1.75 @@ -271,10 +271,12 @@ (defun quit (&key recklessly-p (unix-status 0)) #!+sb-doc - "Terminate the current Lisp. Things are cleaned up (with -UNWIND-PROTECT and so forth) unless RECKLESSLY-P is non-NIL. On -UNIX-like systems, UNIX-STATUS is used as the status code." + "Terminate the current Lisp. *EXIT-HOOKS* are 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) @@ -307,9 +309,7 @@ ;; re-disable ldb again. (when (eq *invoke-debugger-hook* 'sb!debug::debugger-disabled-hook) (sb!debug::disable-debugger)) - (dolist (hook *init-hooks*) - (with-simple-restart (continue "Skip this initialization hook.") - (funcall hook)))) + (call-hooks "initialization" *init-hooks*)) ;;;; some support for any hapless wretches who end up debugging cold ;;;; init code Index: gc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v retrieving revision 1.77 retrieving revision 1.78 diff -u -d -r1.77 -r1.78 --- gc.lisp 5 Oct 2007 14:48:40 -0000 1.77 +++ gc.lisp 10 Jan 2008 11:32:48 -0000 1.78 @@ -248,11 +248,7 @@ ;; for finalizers and after-gc hooks. (when (sb!thread:thread-alive-p sb!thread:*current-thread*) (run-pending-finalizers) - (dolist (hook *after-gc-hooks*) - (handler-case - (funcall hook) - (serious-condition (c) - (warn "Error calling after-GC hook ~S:~% ~A" hook c))))))))) + (call-hooks "after-GC" *after-gc-hooks* :on-error :warn)))))) ;;; This is the user-advertised garbage collection function. (defun gc (&key (gen 0) (full nil) &allow-other-keys) Index: late-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-extensions.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- late-extensions.lisp 15 Jul 2007 22:28:13 -0000 1.15 +++ late-extensions.lisp 10 Jan 2008 11:32:48 -0000 1.16 @@ -140,3 +140,13 @@ (def %compare-and-swap-symbol-plist (symbol) symbol-plist) (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) + +(defun call-hooks (kind hooks &key (on-error :error)) + (dolist (hook hooks) + (handler-case + (funcall hook) + (serious-condition (c) + (if (eq :warn on-error) + (warn "Problem running ~A hook ~S:~% ~A" kind hook c) + (with-simple-restart (continue "Skip this ~A hook." kind) + (error "Problem running ~A hook ~S:~% ~A" kind hook c))))))) Index: save.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/save.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- save.lisp 9 Aug 2007 16:52:03 -0000 1.37 +++ save.lisp 10 Jan 2008 11:32:48 -0000 1.38 @@ -147,9 +147,7 @@ (save-core t))))) (defun deinit () - (dolist (hook *save-hooks*) - (with-simple-restart (continue "Skip this save hook.") - (funcall hook))) + (call-hooks "save" *save-hooks*) (when (rest (sb!thread:list-all-threads)) (error "Cannot save core with multiple threads running.")) (float-deinit) Index: target-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-extensions.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- target-extensions.lisp 5 Jun 2007 02:13:19 -0000 1.15 +++ target-extensions.lisp 10 Jan 2008 11:32:48 -0000 1.16 @@ -35,6 +35,13 @@ been initialized. Unused by SBCL itself: reserved for user and applications.") +(defvar *exit-hooks* nil + #!+sb-doc + "This is a list of functions which are called in an unspecified +order when SBCL process exits. Unused by SBCL itself: reserved for +user and applications. Using (QUIT :RECKLESSLY-P T), or calling +exit(3) directly will circumvent these hooks.") + ;;; Binary search for simple vectors (defun binary-search (value seq &key (key #'identity)) Index: toplevel.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v retrieving revision 1.94 retrieving revision 1.95 diff -u -d -r1.94 -r1.95 --- toplevel.lisp 8 Jun 2007 12:15:46 -0000 1.94 +++ toplevel.lisp 10 Jan 2008 11:32:48 -0000 1.95 @@ -76,7 +76,9 @@ (with-unique-names (caught) `(let ((,caught (catch '%end-of-the-world (/show0 "inside CATCH '%END-OF-THE-WORLD") - ,@body))) + (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) |