From a01e7ac2e8a9f3afae8f759381a0829fceb5bfde Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 10 Jan 2008 11:32:46 +0000 Subject: [PATCH] 1.0.13.20: added SB-EXT:*EXIT-HOOKS* * Also document *INIT-HOOKS* and *SAVE-HOOKS*. * Trailing whitespace cleanup in start-stop.texinfo. --- NEWS | 2 ++ doc/manual/start-stop.texinfo | 56 ++++++++++++++++++++++++--------------- package-data-list.lisp-expr | 5 +++- src/code/cold-init.lisp | 12 ++++----- src/code/gc.lisp | 6 +---- src/code/late-extensions.lisp | 10 +++++++ src/code/save.lisp | 4 +-- src/code/target-extensions.lisp | 7 +++++ src/code/toplevel.lisp | 4 ++- version.lisp-expr | 2 +- 10 files changed, 69 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index f2af05e..574c63c 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.14 relative to sbcl-1.0.13: + * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits + (see documentation for details.) * Revived support for OpenBSD (contributed by Josh Elsasser) * bug fix: RESOLVE-CONFLICT (and the other name conflict machinery) is now actually exported from SB-EXT as documented. (reported by diff --git a/doc/manual/start-stop.texinfo b/doc/manual/start-stop.texinfo index de0589e..77940c2 100644 --- a/doc/manual/start-stop.texinfo +++ b/doc/manual/start-stop.texinfo @@ -3,10 +3,11 @@ @chapter Starting and Stopping @menu -* Starting SBCL:: -* Stopping SBCL:: -* Command Line Options:: -* Initialization Files:: +* Starting SBCL:: +* Stopping SBCL:: +* Command Line Options:: +* Initialization Files:: +* Initialization and Exit Hooks:: @end menu @node Starting SBCL @@ -14,9 +15,9 @@ @section Starting SBCL @menu -* Running from Shell:: -* Running from Emacs:: -* Shebang Scripts:: +* Running from Shell:: +* Running from Emacs:: +* Shebang Scripts:: @end menu @node Running from Shell @@ -77,9 +78,9 @@ an example.) @section Stopping SBCL @menu -* Quit:: +* Quit:: * End of File:: -* Saving a Core Image:: +* Saving a Core Image:: * Exit on Errors:: @end menu @@ -108,9 +109,10 @@ using SBCL as part of a shell pipeline. SBCL has the ability to save its state as a file for later execution. This functionality is important for its bootstrapping -process, and is also provided as an extension to the user. +process, and is also provided as an extension to the user. @include fun-sb-ext-save-lisp-and-die.texinfo +@include var-sb-ext-star-save-hooks-star.texinfo To facilitate distribution of SBCL applications using external resources, the filesystem location of the SBCL core file being used is @@ -163,8 +165,8 @@ passed on to the user program even if they was intended for the runtime system or the Lisp system. @menu -* Runtime Options:: -* Toplevel Options:: +* Runtime Options:: +* Toplevel Options:: @end menu @node Runtime Options @@ -260,10 +262,10 @@ This section covers initialization files processed at startup, which can be used to customize the lisp environment. @menu -* System Initialization File:: -* User Initialization File:: -* Initialization File Semantics:: -* Initialization Examples:: +* System Initialization File:: +* User Initialization File:: +* Initialization File Semantics:: +* Initialization Examples:: @end menu @node System Initialization File @@ -302,8 +304,8 @@ Some examples of what you may consider doing in the initialization files follow. @menu -* Unix-style Command Line Protocol:: -* Automatic Recompilation of Stale Fasls:: +* Unix-style Command Line Protocol:: +* Automatic Recompilation of Stale Fasls:: @end menu @node Unix-style Command Line Protocol @@ -320,7 +322,7 @@ initialization file does the trick: @lisp ;;; If the first user-processable command-line argument is a filename, ;;; disable the debugger, load the file handling shebang-line and quit. -(let ((script (and (second *posix-argv*) +(let ((script (and (second *posix-argv*) (probe-file (second *posix-argv*))))) (when script ;; Handle shebang-line @@ -329,7 +331,7 @@ initialization file does the trick: (declare (ignore char arg)) (read-line stream))) ;; Disable debugger - (setf *invoke-debugger-hook* + (setf *invoke-debugger-hook* (lambda (condition hook) (declare (ignore hook)) ;; Uncomment to get backtraces on errors @@ -378,8 +380,8 @@ handles recompilation automatically for ASDF-based systems. @lisp (require :asdf) -;;; If a fasl was stale, try to recompile and load (once). -(defmethod asdf:perform :around ((o asdf:load-op) +;;; If a fasl was stale, try to recompile and load (once). +(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file)) (handler-case (call-next-method o c) ;; If a fasl was stale, try to recompile and load (once). @@ -387,3 +389,13 @@ handles recompilation automatically for ASDF-based systems. (asdf:perform (make-instance 'asdf:compile-op) c) (call-next-method)))) @end lisp + +@node Initialization and Exit Hooks +@comment node-name, next, previous, up +@section Initialization and Exit Hooks + +SBCL provides hooks into the system initialization and exit. + +@include var-sb-ext-star-init-hooks-star.texinfo +@include var-sb-ext-star-exit-hooks-star.texinfo + diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e100300..a8b42e0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -587,7 +587,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*DEBUG-PRINT-VARIABLE-ALIST*" ;; Hooks into init & save sequences - "*INIT-HOOKS*" "*SAVE-HOOKS*" + "*INIT-HOOKS*" "*SAVE-HOOKS*" "*EXIT-HOOKS*" ;; There is no one right way to report progress on ;; hairy compiles. @@ -825,6 +825,9 @@ possibly temporariliy, because it might be used internally." ;; name to the string if possible "BLOCK-GENSYM" + ;; Calling a list of hook functions, plus error handling. + "CALL-HOOKS" + ;; Constant form evaluation "CONSTANT-FORM-VALUE" "CONSTANT-TYPEP" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 9e3359e..f0c780a 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -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 @@ UNIX-like systems, UNIX-STATUS is used as the status code." ;; 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 diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 7ba3b3b..c4f84de 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -248,11 +248,7 @@ run in any thread.") ;; 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) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index f6c5f25..1918c87 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -140,3 +140,13 @@ EXPERIMENTAL: Interface subject to change." (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))))))) diff --git a/src/code/save.lisp b/src/code/save.lisp index bb0bcc5..0373fce 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -147,9 +147,7 @@ sufficiently motivated to do lengthy fixes." (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) diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index 259f3d7..f65e25d 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -35,6 +35,13 @@ order when a saved core image starts up, after the system itself has 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)) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index eddb5f8..4cc0b0c 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -76,7 +76,9 @@ command-line.") (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) diff --git a/version.lisp-expr b/version.lisp-expr index 4825adf..78a7e73 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.13.19" +"1.0.13.20" -- 1.7.10.4