Index: src/assembly/x86/assem-rtns.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/x86/assem-rtns.lisp,v retrieving revision 1.14 diff -u -b -r1.14 assem-rtns.lisp --- src/assembly/x86/assem-rtns.lisp 5 Dec 2006 15:07:16 -0000 1.14 +++ src/assembly/x86/assem-rtns.lisp 11 Jan 2007 19:49:53 -0000 @@ -228,6 +228,7 @@ ;;;; non-local exit noise +#!-win32 (define-assembly-routine (unwind (:return-style :none) (:translate %continue-unwind) @@ -255,21 +256,6 @@ ;; 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 @@ -278,16 +264,6 @@ 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 @@ -295,30 +271,29 @@ ;; count in ecx-tn. (inst jmp (make-ea :byte :base block - :disp (* unwind-block-entry-pc-slot n-word-bytes))) + :disp (* unwind-block-entry-pc-slot n-word-bytes)))) + + +;;;; Win32 non-local exit noise - #!+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. +#!+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) - ;; 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 + ;; 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 @@ -340,16 +315,14 @@ (inst push 0) (inst push 0) (inst push ecx-tn) - (inst call (make-fixup "RtlUnwind@16" :foreign)))) + (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. @@ -363,6 +336,136 @@ (dotimes (i 8) (inst fldz)) - ;; Restore our regs and pick up where we left off. + ;; 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)))) + + +;;;; Win32 UWP block SEH interface. + +;; 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) + + ;; 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)) Index: src/compiler/generic/objdef.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/objdef.lisp,v retrieving revision 1.51 diff -u -b -r1.51 objdef.lisp --- src/compiler/generic/objdef.lisp 5 Dec 2006 04:35:57 -0000 1.51 +++ src/compiler/generic/objdef.lisp 11 Jan 2007 19:49:53 -0000 @@ -279,13 +279,17 @@ (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) Index: src/compiler/x86/nlx.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/nlx.lisp,v retrieving revision 1.19 diff -u -b -r1.19 nlx.lisp --- src/compiler/x86/nlx.lisp 15 Nov 2005 12:49:30 -0000 1.19 +++ src/compiler/x86/nlx.lisp 11 Jan 2007 19:49:53 -0000 @@ -80,7 +80,12 @@ (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 @@ -97,6 +102,11 @@ (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) @@ -106,9 +116,18 @@ ;;; 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) @@ -121,11 +140,17 @@ (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))) Index: src/compiler/x86/vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/vm.lisp,v retrieving revision 1.24 diff -u -b -r1.24 vm.lisp --- src/compiler/x86/vm.lisp 7 Feb 2006 02:35:25 -0000 1.24 +++ src/compiler/x86/vm.lisp 11 Jan 2007 19:49:53 -0000 @@ -160,7 +160,8 @@ ;;; (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 Index: src/runtime/win32-os.c =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/win32-os.c,v retrieving revision 1.27 diff -u -b -r1.27 win32-os.c --- src/runtime/win32-os.c 9 Jan 2007 18:10:09 -0000 1.27 +++ src/runtime/win32-os.c 11 Jan 2007 19:49:53 -0000 @@ -43,6 +43,7 @@ #include "runtime.h" #include "alloc.h" #include "genesis/primitive-objects.h" +#include "dynbind.h" #include #include @@ -320,8 +321,18 @@ 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]; Index: src/runtime/win32-os.h =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/win32-os.h,v retrieving revision 1.3 diff -u -b -r1.3 win32-os.h --- src/runtime/win32-os.h 9 Jan 2007 18:10:10 -0000 1.3 +++ src/runtime/win32-os.h 11 Jan 2007 19:49:53 -0000 @@ -43,6 +43,7 @@ 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); Index: src/runtime/x86-assem.S =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/x86-assem.S,v retrieving revision 1.37 diff -u -b -r1.37 x86-assem.S --- src/runtime/x86-assem.S 9 Jan 2007 18:10:10 -0000 1.37 +++ src/runtime/x86-assem.S 11 Jan 2007 19:49:54 -0000 @@ -274,6 +274,19 @@ 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 @@ -289,6 +302,12 @@ 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 @@ -845,6 +864,41 @@ 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) */ + /* some other stuff we don't care about. */ + pushl %ebp + movl 0x10(%esp), %ebp /* context */ + pushl 0xb8(%ebp) /* context->Eip */ + pushl 0xb4(%ebp) /* context->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) Index: tests/win32-foreign-stack-unwind.impure.lisp =================================================================== RCS file: tests/win32-foreign-stack-unwind.impure.lisp diff -N tests/win32-foreign-stack-unwind.impure.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ tests/win32-foreign-stack-unwind.impure.lisp 11 Jan 2007 19:49:54 -0000 @@ -0,0 +1,206 @@ +;;;; 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! Index: tests/win32-stack-unwind.c =================================================================== RCS file: tests/win32-stack-unwind.c diff -N tests/win32-stack-unwind.c --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ tests/win32-stack-unwind.c 11 Jan 2007 19:49:54 -0000 @@ -0,0 +1,127 @@ +/* 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 +#include + +#define WIN32_LEAN_AND_MEAN +#include +#include + + +/* 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 */