mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
f0da2f63aa
Deprecate QUIT. It occupies an uncomfortable niche between processes
and threads, and doesn't actually do what it says on the tin unless
you call it from the main thread.
SIGTERM now uses EXIT, and doesn't depend on sessions.
WITH-DEADLINE (:SECONDS NIL :OVERRIDE T) can now be used to ignore
deadlines.
JOIN-THREAD on the main thread now blocks indefinitely instead of
claiming the thread did not exit normally.
New functions:
* SB-EXT:EXIT. Always exits the process. Takes keywords :CODE,
:ABORT, and :TIMEOUT. Code is the exit status. Abort controls if
the exit is clean (unwind, exit-hooks, terminate other threads) or
dirty. Timeout controls how long to wait for other threads to
finish.
* SB-THREAD:RETURN-FROM-THREAD. Normal termination for current
thread -- equivalent to return from the thread function with the
specified values. Takes keyword :ALLOW-EXIT, which determines if
returning from the main thread is an error, or equivalent to
calling EXIT :CODE 0.
* SB-THREAD:ABORT-THREAD. Abnormal termination for current thread --
equivalent to invoking the initial ABORT restart estabilished by
MAKE-THREAD (previously known as TERMINATE-THREAD, but ANSI
recommends there to always be an ABORT restart.) Takes keyword
:ALLOW-EXIT, which determines if aborting the main thread is an
error, or equivalent to calling EXIT :CODE 1.
* SB-THREAD:MAIN-THREAD-P. Let's you determine if a given thread is
the main thread of the process. This is important for some
functions on some operating systems -- and RETURN-FROM-THREAD and
ABORT-THREAD also need it.
* SB-THREAD:MAIN-THREAD. Returns the main thread object. Convenient
for when you need to eg. load a foreign library in the main
thread.
208 lines
7.7 KiB
Common Lisp
Executable file
208 lines
7.7 KiB
Common Lisp
Executable file
;;;; Testing the behavior of foreign calls trying to unwind the stack. Uses win32-stack-unwind.c.
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
#-win32 (exit :code 104) ;; This is extremely win32-specific.
|
|
|
|
(use-package :sb-alien)
|
|
|
|
;;; Callbacks are not part of the exported interface yet -- when they are this can
|
|
;;; go away.
|
|
(import 'sb-alien::alien-lambda)
|
|
|
|
;;; XXX XXX this should change to use run-compiler.sh, now that we have it
|
|
(defun run-compiler ()
|
|
(let ((proc (run-program "gcc" '("win32-stack-unwind.c"
|
|
"-mno-cygwin" "-shared"
|
|
"-o" "win32-stack-unwind.dll")
|
|
:search t)))
|
|
(unless (zerop (process-exit-code proc))
|
|
(error "Bad exit code: ~S"
|
|
(process-exit-code proc)))))
|
|
|
|
(run-compiler)
|
|
|
|
(load-shared-object (truename "win32-stack-unwind.dll"))
|
|
|
|
|
|
(defvar *current-test-callback*)
|
|
|
|
(defparameter *test-callback-thunk*
|
|
(sb-alien::alien-callback
|
|
(function void)
|
|
#'(lambda () (funcall *current-test-callback*))))
|
|
|
|
(defun establish-return-frame (callback)
|
|
"Establish an SEH frame for use as a target with PERFORM-TEST-UNWIND and invoke CALLBACK via FUNCALL"
|
|
;; We don't use a LET here because we don't want to accidentally
|
|
;; correct a blown binding stack pointer just yet.
|
|
(setf *current-test-callback* callback)
|
|
(alien-funcall (extern-alien "establish_return_frame"
|
|
(function void (* (function void))))
|
|
(alien-sap *test-callback-thunk*))
|
|
(makunbound '*current-test-callback*)
|
|
(values))
|
|
|
|
(defun perform-test-unwind ()
|
|
"Perform an RtlUnwind to the surrounding ESTABLISH-RETURN-FRAME frame."
|
|
(alien-funcall (extern-alien "perform_test_unwind" (function void))))
|
|
|
|
|
|
;;; An attempt to detect and clean up latent fatalities in the
|
|
;;; post-test environent.
|
|
|
|
(defmacro with-test-environment (args &body body)
|
|
(declare (ignore args))
|
|
(let ((old-bsp (gensym))
|
|
(old-cuwp (gensym))
|
|
(old-ccb (gensym))
|
|
(old-asp (gensym)))
|
|
`(let ((*standard-input* *standard-input*))
|
|
(let ((,old-bsp (+ sb-vm::*binding-stack-pointer* 2))
|
|
(,old-cuwp sb-vm::*current-unwind-protect-block*)
|
|
(,old-ccb sb-vm:*current-catch-block*)
|
|
(,old-asp sb-vm::*alien-stack*))
|
|
(handler-case
|
|
(let ((result (progn ,@body))
|
|
extra-results)
|
|
(when (not (eql ,old-bsp sb-vm::*binding-stack-pointer*))
|
|
#+(or)
|
|
(format t "~A ~A~%" ,old-bsp sb-vm::*binding-stack-pointer*)
|
|
(push :bsp-fail extra-results))
|
|
(when (not (eql ,old-cuwp sb-vm::*current-unwind-protect-block*))
|
|
(push :cuwp-fail extra-results))
|
|
(when (not (eql ,old-ccb sb-vm:*current-catch-block*))
|
|
(push :ccb-fail extra-results))
|
|
(when (not (eql ,old-asp sb-vm::*alien-stack*))
|
|
(push :asp-fail extra-results))
|
|
(setf sb-vm::*current-unwind-protect-block* ,old-cuwp)
|
|
(setf sb-vm:*current-catch-block* ,old-ccb)
|
|
(setf sb-vm::*alien-stack* ,old-asp)
|
|
(list* result extra-results))
|
|
(error ()
|
|
:error))))))
|
|
|
|
|
|
;;; Test cases.
|
|
|
|
(with-test (:name #1=:base-case)
|
|
;; Tests that the unwind test machinery works.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(establish-return-frame (lambda () (perform-test-unwind)))
|
|
:success)))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:special-binding)
|
|
;; Tests that special bindings are undone properly during
|
|
;; unwind.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(let ((foo :success))
|
|
(declare (special foo))
|
|
(establish-return-frame (lambda ()
|
|
(let ((foo nil))
|
|
(declare (special foo))
|
|
(perform-test-unwind))))
|
|
foo))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:unwind-protect)
|
|
;; Tests that unwind-protect forms are run during unwind.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(let (result)
|
|
(establish-return-frame (lambda ()
|
|
(unwind-protect
|
|
(perform-test-unwind)
|
|
(setf result :success))))
|
|
result))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:unwind-protect-nlx)
|
|
;; Tests that unwind-protect forms that are run during unwind
|
|
;; can do a non-local exit to abort the unwind.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(let (result)
|
|
(establish-return-frame (lambda ()
|
|
(block nil
|
|
(unwind-protect
|
|
(perform-test-unwind)
|
|
(return)))
|
|
(setf result :success)))
|
|
result))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:no-unwind)
|
|
;; Basic smoke test of establish-return-frame.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(establish-return-frame (lambda ()))
|
|
:success)))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:no-unwind-error)
|
|
;; Tests that EXCEPTION_BREAKPOINT is caught and handled
|
|
;; correctly within callbacks.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(establish-return-frame (lambda ()
|
|
(handler-case
|
|
(some-undefined-function)
|
|
(undefined-function ()))))
|
|
:success)))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:unwind-foreign-frame)
|
|
;; Tests that unwinding a foreign SEH frame isn't completely
|
|
;; broken.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(block nil
|
|
(establish-return-frame (lambda () (return :success)))))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:unwind-protect-unwind-foreign-frame)
|
|
;; Tests that an unwind-protect block is allowed to unwind
|
|
;; past the original unwind target.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(block nil
|
|
(establish-return-frame (lambda ()
|
|
(unwind-protect
|
|
(perform-test-unwind)
|
|
(return :success))))))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
(with-test (:name #1=:unwind-error)
|
|
;; Another test for unwinding an SEH frame.
|
|
(let ((result
|
|
(with-test-environment ()
|
|
(handler-case
|
|
(establish-return-frame (lambda ()
|
|
(error "Foo!")))
|
|
(error ()
|
|
:success)))))
|
|
(format t "~S result: ~S~%" #1# result)
|
|
(assert (eql :success (car result)))))
|
|
|
|
;;;; success!
|