non-local exit.
Revert src/assembly/x86/assem-rtns.lisp changes of version 1.0.0.19.
Add Win32 SEH frame to catch-block and unwind-block object
definitions.
Changed VOPs in src/compiler/x86/nlx.lisp to set up SEH frames for
unwind-protect and unwind targets.
Added Win32-specific assembly-routines to handle unwinding and
unwind-protect frames.
Added an SEH frame to call_into_lisp.
Added a wrapper around the runtime exception handler to provide a
set of continuous stack frames over the system unwind logic (which
doesn't maintain EBP properly, thus breaking backtraces).
Added test cases for unwinding lisp stack frames from alien code.
* bug fix: an error is signaled for tagbodies with duplicate tags
(thanks to Stephen Wilson)
* bug fix: NIL can be used as a tagbody tag (thanks to Stephen Wilson)
+ * bug fix: Win32 port can now handle foreign code unwinding Lisp
+ stack frames from alien callbacks.
changes in sbcl-1.0.1 relative to sbcl-1.0:
* new platform: FreeBSD/x86-64, including support for threading.
;;;; non-local exit noise
+#!-win32
(define-assembly-routine (unwind
(:return-style :none)
(:translate %continue-unwind)
;; Important! Must save (and return) the arg 'block' for later use!!
(move edx-tn block)
(move block uwp)
-
- ;; We need to check for Win32 exception frames before overwriting
- ;; *C-U-P-B* (if the Win32 frames NLX, we need the UWP to still be
- ;; live.) As of this writing, we can't take a Win32 NLX across our
- ;; frames, but the frame can NLX to another foreign frame that
- ;; doesn't cross ours and then return normally, and if we drop the
- ;; UWP beforehand then we just broke UWP semantics.
- #!+win32
- (assemble ()
- (inst fs-segment-prefix)
- (inst cmp block (make-ea :dword))
- (inst jmp :le NO-WIN32-UNWIND)
- (inst call WIN32-UNWIND)
- NO-WIN32-UNWIND)
-
;; Set next unwind protect context.
(loadw uwp uwp unwind-block-current-uwp-slot)
;; we're about to reload ebp anyway, so let's borrow it here as a
DO-EXIT
- ;; Same as above with *C-U-P-B*, except that this is for our target
- ;; block, not a UWP. Still need to check for Win32 exception frames.
- #!+win32
- (assemble ()
- (inst fs-segment-prefix)
- (inst cmp block (make-ea :dword))
- (inst jmp :le NO-WIN32-UNWIND)
- (inst call WIN32-UNWIND)
- NO-WIN32-UNWIND)
-
(loadw ebp-tn block unwind-block-current-cont-slot)
;; Uwp-entry expects some things in known locations so that they can
;; count in ecx-tn.
(inst jmp (make-ea :byte :base block
- :disp (* unwind-block-entry-pc-slot n-word-bytes)))
-
- #!+win32
- WIN32-UNWIND
- ;; At this point we need to call RtlUnwind@16 to clear up one or
- ;; more Win32 exception frames on the stack. This is an unusual FFI
- ;; in that it kills most of the registers, and it returns to the
- ;; address at [EBP+4].
- #!+win32
- (assemble ()
- ;; Regs get clobbered by this process, so save the lot of them.
- (inst pusha)
-
- ;; Okay, our current unwind target is in BLOCK (EAX). All of our
- ;; other regs are on the stack. We need to find the first Win32
- ;; exception frame that we -aren't- going to unwind.
- (inst fs-segment-prefix)
- (inst mov ecx-tn (make-ea :dword))
- FIND-TARGET-FRAME
- (inst cmp block ecx-tn)
- (inst jmp :le FOUND-TARGET-FRAME)
- (inst mov ecx-tn (make-ea :dword :base ecx-tn))
- (inst jmp FIND-TARGET-FRAME)
- FOUND-TARGET-FRAME
-
- ;; This section copied from VOP CALL-OUT.
- ;; Setup the NPX for C; all the FP registers need to be
- ;; empty; pop them all.
- (dotimes (i 8)
- (inst fstp fr0-tn))
-
- ;; I'm unlikely to ever forget this again.
- (inst cld)
-
- ;; Set up a bogus stack frame for RtlUnwind to pick its return
- ;; address from. (Yes, this is how RtlUnwind works.)
- (inst push (make-fixup 'win32-unwind-tail :assembly-routine))
- (inst push ebp-tn)
- (inst mov ebp-tn esp-tn)
-
- ;; Actually call out for the unwind.
- (inst push 0)
- (inst push 0)
- (inst push 0)
- (inst push ecx-tn)
- (inst call (make-fixup "RtlUnwind@16" :foreign))))
+ :disp (* unwind-block-entry-pc-slot n-word-bytes))))
+
+
+;;;; Win32 non-local exit noise
+
+#!+win32
+(define-assembly-routine (unwind
+ (:return-style :none)
+ (:policy :fast-safe))
+ ((:arg block (any-reg descriptor-reg) eax-offset)
+ (:arg start (any-reg descriptor-reg) ebx-offset)
+ (:arg count (any-reg descriptor-reg) ecx-offset))
+ (declare (ignore start count))
+
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst or block block) ; check for NULL pointer
+ (inst jmp :z error))
+
+ ;; Save all our registers, as we're about to clobber them.
+ (inst pusha)
+
+ ;; Find the SEH frame surrounding our target.
+ (loadw ecx-tn block unwind-block-next-seh-frame-slot)
+
+ ;; This section copied from VOP CALL-OUT.
+ ;; Setup the NPX for C; all the FP registers need to be
+ ;; empty; pop them all.
+ (dotimes (i 8)
+ (inst fstp fr0-tn))
+
+ ;; I'm unlikely to ever forget this again.
+ (inst cld)
+
+ ;; Set up a bogus stack frame for RtlUnwind to pick its return
+ ;; address from. (Yes, this is how RtlUnwind works.)
+ (inst push (make-fixup 'win32-unwind-tail :assembly-routine))
+ (inst push ebp-tn)
+ (inst mov ebp-tn esp-tn)
+
+ ;; Actually call out for the unwind.
+ (inst push 0)
+ (inst push 0)
+ (inst push 0)
+ (inst push ecx-tn)
+ (inst call (make-fixup "RtlUnwind@16" :foreign)))
;; We want no VOP for this one and for it to only happen on Win32
;; targets. Hence the following disaster.
-#!+win32
-#-sb-assembling nil
-#+sb-assembling
+#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or))
(define-assembly-routine
(win32-unwind-tail (:return-style :none))
- ()
+ ((:temp block unsigned-reg eax-offset))
+
+ ;; The unwind returns here. Had to use a VOP for this because
+ ;; PUSH won't accept a label as an argument.
+
+ ;; Clean up the bogus stack frame we pushed for the unwind.
+ (inst pop ebp-tn)
+ (inst pop esi-tn) ;; Random scratch register.
+
+ ;; This section based on VOP CALL-OUT.
+ ;; Restore the NPX for lisp; ensure no regs are empty
+ (dotimes (i 8)
+ (inst fldz))
+
+ ;; Restore our regs.
+ (inst popa)
+
+ ;; By now we've unwound all the UWP frames required, so we
+ ;; just jump to our target block.
+ (loadw ebp-tn block unwind-block-current-cont-slot)
+
+ ;; Nlx-entry expects the arg start in ebx-tn and the arg count
+ ;; in ecx-tn. Fortunately, that's where they are already.
+ (inst jmp (make-ea :byte :base block
+ :disp (* unwind-block-entry-pc-slot n-word-bytes))))
- ;; The unwind returns here. Had to use a VOP for this because
- ;; PUSH won't accept a label as an argument.
- ;; Clean up the bogus stack frame we pushed for the unwind.
- (inst pop ebp-tn)
- (inst pop esi-tn) ;; Random scratch register.
+;;;; Win32 UWP block SEH interface.
- ;; This section based on VOP CALL-OUT.
- ;; Restore the NPX for lisp; ensure no regs are empty
- (dotimes (i 8)
- (inst fldz))
+;; We want no VOP for this one and for it to only happen on Win32
+;; targets. Hence the following disaster.
+#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or))
+(define-assembly-routine
+ (uwp-seh-handler (:return-style :none))
+ ((:temp block unsigned-reg eax-offset))
+
+ ;; We get called for any exception which happens within our
+ ;; dynamic contour that isn't handled below us, and for
+ ;; unwinding.
+
+ ;; For the exceptions we just return ExceptionContinueSearch.
+
+ ;; Find the exception record.
+ (inst mov eax-tn (make-ea :dword :base esp-tn :disp 4))
+
+ ;; Check unwind flags.
+ (inst test (make-ea :byte :base eax-tn :disp 4) 6) ; EH_UNWINDING | EH_EXIT_UNWIND
+
+ ;; To see if we're unwinding or not.
+ (inst jmp :nz UNWINDING)
+
+ ;; We're not unwinding, so we're not interested.
+ (inst mov eax-tn 1) ;; exception-continue-search
+ (inst ret)
+
+ ;; For the unwinds we establish a basic environment as per
+ ;; call_into_lisp, but without the extra SEH frame (the theory
+ ;; being that we're already in a Lisp SEH context), and invoke
+ ;; our UWP block to unwind itself.
+
+ ;; FIXME: Do we need to establish an SEH frame anyway? And do
+ ;; we need to do the same stack frame hackery for the debugger
+ ;; as we do for the main exception handler?
+
+ ;; When the UWP block calls %continue-unwind, we come back to
+ ;; the next assembly routine, below, which reinitializes for C
+ ;; and returns to the Win32 unwind machinery.
+
+ ;; If the UWP block sees fit to do a non-local exit, things
+ ;; Just Work, thanks to the Win32 API being sanely designed
+ ;; and our complying with it.
+
+ ;; We also must update *current-unwind-protect-block* before
+ ;; calling the cleanup function.
+
+ UNWINDING
+
+ ;; Save all registers (overkill)
+ (inst pusha)
- ;; Restore our regs and pick up where we left off.
- (inst popa)
- (inst ret))
+ ;; Establish our stack frame.
+ (inst mov ebp-tn esp-tn)
+
+ ;; This section based on VOP CALL-OUT.
+ ;; Restore the NPX for lisp; ensure no regs are empty
+ (dotimes (i 8)
+ (inst fldz))
+
+ ;; Find our unwind-block by way of our SEH frame.
+ (inst mov block (make-ea :dword :base ebp-tn :disp #x28))
+ (inst lea block (make-ea :dword :base block
+ :disp (- (* unwind-block-next-seh-frame-slot
+ n-word-bytes))))
+
+ ;; Update *CURRENT-UNWIND-PROTECT-BLOCK*.
+ (loadw ebx-tn block unwind-block-current-uwp-slot)
+ (store-tl-symbol-value ebx-tn *current-unwind-protect-block* ecx-tn)
+
+ ;; Uwp-entry expects some things in known locations so that they can
+ ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
+ ;; count in ecx-tn. We don't actually have any of that here, but we
+ ;; do need to have access to our own stack frame, so we hijack the
+ ;; known locations to cover our own state.
+
+ (inst xor ebx-tn ebx-tn)
+ (inst xor ecx-tn ecx-tn)
+ (inst mov ebx-tn ebp-tn)
+ (loadw ebp-tn block unwind-block-current-cont-slot)
+ (inst jmp (make-ea :byte :base block
+ :disp (* unwind-block-entry-pc-slot n-word-bytes))))
+
+#!+win32
+(define-assembly-routine (continue-unwind
+ (:return-style :none)
+ (:translate %continue-unwind)
+ (:policy :fast-safe))
+ ((:arg block (any-reg descriptor-reg) eax-offset)
+ (:arg start (any-reg descriptor-reg) ebx-offset)
+ (:arg count (any-reg descriptor-reg) ecx-offset))
+ (declare (ignore block count))
+ ;; The args here are mostly ignored because we're using the
+ ;; win32 unwind mechanism and keep all that elsewhere. The
+ ;; exception is START, which we use to pass the saved EBP for
+ ;; our exception handler.
+
+ ;; "All" we have to do here is reload our EBP, reestablish a C
+ ;; environment, and return ExceptionContinueSearch. The OS
+ ;; handles the rest.
+
+ ;; Restore our frame pointer.
+ (inst mov esp-tn start)
+
+ ;; This section copied from VOP CALL-OUT.
+ ;; Setup the NPX for C; all the FP registers need to be
+ ;; empty; pop them all.
+ (dotimes (i 8)
+ (inst fstp fr0-tn))
+
+ ;; I'm unlikely to ever forget this again.
+ (inst cld)
+
+ ;; Restore our saved registers
+ (inst popa)
+
+ ;; And we're done.
+ (inst mov eax-tn 1) ;; exception-continue-search
+ (inst ret))
(current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
(current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
#!-(or x86 x86-64) current-code
- entry-pc)
+ entry-pc
+ #!+win32 next-seh-frame
+ #!+win32 seh-frame-handler)
(define-primitive-object (catch-block)
(current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
(current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
#!-(or x86 x86-64) current-code
entry-pc
+ #!+win32 next-seh-frame
+ #!+win32 seh-frame-handler
tag
(previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32")
size)
(storew temp block unwind-block-current-uwp-slot)
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
- block catch-block-entry-pc-slot)))
+ block catch-block-entry-pc-slot)
+ #!+win32
+ (progn
+ (inst fs-segment-prefix)
+ (inst mov temp (make-ea :dword :disp 0))
+ (storew temp block unwind-block-next-seh-frame-slot))))
;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
;;; tag, and link the block into the CURRENT-CATCH list
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)
+ #!+win32
+ (progn
+ (inst fs-segment-prefix)
+ (inst mov temp (make-ea :dword :disp 0))
+ (storew temp block unwind-block-next-seh-frame-slot))
(storew tag block catch-block-tag-slot)
(load-tl-symbol-value temp *current-catch-block*)
(storew temp block catch-block-previous-catch-slot)
;;; unwind block as an unwind-protect.
(define-vop (set-unwind-protect)
(:args (tn))
- (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls)
+ (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls #!+win32 seh-frame)
(:generator 7
(inst lea new-uwp (catch-block-ea tn))
+ #!+win32
+ (progn
+ (storew (make-fixup 'uwp-seh-handler :assembly-routine)
+ new-uwp unwind-block-seh-frame-handler-slot)
+ (inst lea seh-frame
+ (make-ea-for-object-slot new-uwp
+ unwind-block-next-seh-frame-slot 0))
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :dword :disp 0) seh-frame))
(store-tl-symbol-value new-uwp *current-unwind-protect-block* tls)))
(define-vop (unlink-catch-block)
(store-tl-symbol-value block *current-catch-block* tls)))
(define-vop (unlink-unwind-protect)
- (:temporary (:sc unsigned-reg) block #!+sb-thread tls)
+ ;; NOTE: When we have both #!+sb-thread and #!+win32, we only need one temp
+ (:temporary (:sc unsigned-reg) block #!+sb-thread tls #!+win32 seh-frame)
(:policy :fast-safe)
(:translate %unwind-protect-breakup)
(:generator 17
(load-tl-symbol-value block *current-unwind-protect-block*)
+ #!+win32
+ (progn
+ (loadw seh-frame block unwind-block-next-seh-frame-slot)
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :dword :disp 0) seh-frame))
(loadw block block unwind-block-current-uwp-slot)
(store-tl-symbol-value block *current-unwind-protect-block* tls)))
\f
;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess
;;; has my gratitude.) (FIXME: Maybe this should be me..)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (def!constant kludge-nondeterministic-catch-block-size 6))
+ (def!constant kludge-nondeterministic-catch-block-size
+ #!-win32 6 #!+win32 8))
(!define-storage-classes
#include "runtime.h"
#include "alloc.h"
#include "genesis/primitive-objects.h"
+#include "dynbind.h"
#include <sys/types.h>
#include <signal.h>
handle_exception(EXCEPTION_RECORD *exception_record,
struct lisp_exception_frame *exception_frame,
CONTEXT *context,
- void *dc) /* FIXME: What's dc again? */
+ void *dispatcher_context)
{
+ if (exception_record->ExceptionFlags & (EH_UNWINDING | EH_EXIT_UNWIND)) {
+ /* If we're being unwound, be graceful about it. */
+
+ /* Undo any dynamic bindings. */
+ unbind_to_here(exception_frame->bindstack_pointer,
+ arch_os_get_current_thread());
+
+ return ExceptionContinueSearch;
+ }
+
/* For EXCEPTION_ACCESS_VIOLATION only. */
void *fault_address = (void *)exception_record->ExceptionInformation[1];
struct lisp_exception_frame {
struct lisp_exception_frame *next_frame;
void *handler;
+ lispobj *bindstack_pointer;
};
void wos_install_interrupt_handlers(struct lisp_exception_frame *handler);
Ldone:
/* Registers eax, ecx, edx, edi, and esi are now live. */
+#ifdef LISP_FEATURE_WIN32
+ /* Establish an SEH frame. */
+#ifdef LISP_FEATURE_SB_THREAD
+ /* FIXME: need to save BSP here. */
+#error need to save BSP here, but don't know how yet.
+#else
+ pushl BINDING_STACK_POINTER + SYMBOL_VALUE_OFFSET
+#endif
+ pushl $GNAME(exception_handler_wrapper)
+ pushl %fs:0
+ movl %esp, %fs:0
+#endif
+
/* Alloc new frame. */
mov %esp,%ebx # The current sp marks start of new frame.
push %ebp # fp in save location S0
LsingleValue:
/* A singled value function returns here */
+#ifdef LISP_FEATURE_WIN32
+ /* Remove our SEH frame. */
+ popl %fs:0
+ add $8, %esp
+#endif
+
/* Restore the stack, in case there was a stack change. */
popl %esp # c-sp
SIZE(GNAME(alloc_overflow_edi))
+#ifdef LISP_FEATURE_WIN32
+ /* The guts of the exception-handling system doesn't use
+ * frame pointers, which manages to throw off backtraces
+ * rather badly. So here we grab the (known-good) EBP
+ * and EIP from the exception context and use it to fake
+ * up a stack frame which will skip over the system SEH
+ * code. */
+ .align align_4byte
+ .globl GNAME(exception_handler_wrapper)
+ TYPE(GNAME(exception_handler_wrapper))
+GNAME(exception_handler_wrapper):
+ /* Context layout is: */
+ /* 7 dwords before FSA. (0x1c) */
+ /* 8 dwords and 0x50 bytes in the FSA. (0x70/0x8c) */
+ /* 4 dwords segregs. (0x10/0x9c) */
+ /* 6 dwords non-stack GPRs. (0x18/0xb4) */
+ /* EBP (at 0xb4) */
+ /* EIP (at 0xb8) */
+#define CONTEXT_EBP_OFFSET 0xb4
+#define CONTEXT_EIP_OFFSET 0xb8
+ /* some other stuff we don't care about. */
+ pushl %ebp
+ movl 0x10(%esp), %ebp /* context */
+ pushl CONTEXT_EIP_OFFSET(%ebp)
+ pushl CONTEXT_EBP_OFFSET(%ebp)
+ movl %esp, %ebp
+ pushl 0x1c(%esp)
+ pushl 0x1c(%esp)
+ pushl 0x1c(%esp)
+ pushl 0x1c(%esp)
+ call GNAME(handle_exception)
+ lea 8(%ebp), %esp
+ popl %ebp
+ ret
+ SIZE(GNAME(exception_handler_wrapper))
+#endif
+
#ifdef LISP_FEATURE_DARWIN
.align align_4byte
.globl GNAME(call_into_lisp_tramp)
--- /dev/null
+;;;; 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 (quit :unix-status 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)
+
+(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 "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!
--- /dev/null
+/* Compiled and loaded by win32-foreign-stack-unwind.impure.lisp
+ *
+ * establish_return_frame(callback_ptr) establishes an SEH frame
+ * that will cause an unwind to itself followed by a return on
+ * any exception, and then calls the callback_ptr.
+ *
+ * perform_test_unwind() does an unwind to the SEH frame
+ * established by establish_return_frame().
+ *
+ * The name of the game for the tests is to establish a callback
+ * that establishes something with a dynamic contour and
+ * possibly a control transfer semantic (such as a binding or an
+ * unwind-protect) and then call perform_test_unwind() or cause
+ * an exception that should be handled by SBCL and see what
+ * breaks.
+ */
+
+/* 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.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#include <excpt.h>
+
+
+/* The "public" API */
+
+typedef void (*callback_ptr)(void);
+
+void establish_return_frame(callback_ptr callback);
+void perform_test_unwind(void);
+
+
+/* The implementation */
+
+static
+void **saved_exception_frame;
+
+static
+DWORD saved_ebp;
+
+static void *get_seh_frame(void)
+{
+ void* retval;
+ asm volatile ("movl %%fs:0,%0": "=r" (retval));
+ return retval;
+}
+
+static void set_seh_frame(void *frame)
+{
+ asm volatile ("movl %0,%%fs:0": : "r" (frame));
+}
+
+
+static
+EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record,
+ void **exception_frame,
+ CONTEXT *context,
+ void *dc)
+{
+ /* If an exception occurs and is passed to us to handle, just
+ * unwind. One or more test cases check for SBCL handling
+ * breakpoint exceptions properly. This makes sure that it
+ * doesn't unless a new exception frame is estabished when a
+ * callback occurs. */
+ if (!(exception_record->ExceptionFlags
+ & (EH_UNWINDING | EH_EXIT_UNWIND))) {
+ perform_test_unwind();
+ }
+
+ return ExceptionContinueSearch;
+}
+
+static void invoke_callback(callback_ptr callback, DWORD *unwind_token);
+
+asm("_invoke_callback:"
+ "pushl %ebp; movl %esp, %ebp;"
+ "movl 12(%ebp), %eax;"
+ "movl %ebp, (%eax);"
+ "call *8(%ebp);"
+ "movl %ebp, %esp; popl %ebp; ret");
+
+static void do_unwind(void *target_frame, DWORD unwind_token);
+asm("_do_unwind:"
+ "pushl $target; pushl %ebp; movl %esp, %ebp;"
+ "pushl $0xcafe; pushl $0; pushl $-1; pushl 12(%ebp); call _RtlUnwind@16;"
+ "target:"
+ "movl 16(%ebp), %esp; popl %ebp; ret");
+
+
+void establish_return_frame(callback_ptr callback)
+{
+ void *exception_frame[2];
+
+ saved_exception_frame = exception_frame;
+ exception_frame[0] = get_seh_frame();
+ exception_frame[1] = handle_exception;
+ set_seh_frame(exception_frame);
+
+ invoke_callback(callback, &saved_ebp);
+
+ if (exception_frame != get_seh_frame()) {
+ /* It is never good for this to happen. */
+ printf("exception frame mismatch on callback return.\n");
+ }
+
+ set_seh_frame(exception_frame[0]);
+}
+
+void perform_test_unwind(void)
+{
+ do_unwind(saved_exception_frame, saved_ebp);
+}
+
+/* EOF */
;;; 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.1.23"
+"1.0.1.24"
projects / sbcl.git / commitdiff