From: Nikodemus Siivola Date: Tue, 5 Dec 2006 15:07:15 +0000 (+0000) Subject: 1.0.0.19: unwinding from foreign exception frames when doing X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=13deb21bc0d8e9d68b3f449ca971c3c7fd332f4b;p=sbcl.git 1.0.0.19: unwinding from foreign exception frames when doing a non-local exit from alien code * Patch and test by Alastair Bridgewater. * Advertise our newfound stability in NEWS (since the stack-start patch). --- diff --git a/NEWS b/NEWS index 6d79fba..f30350f 100644 --- a/NEWS +++ b/NEWS @@ -9,8 +9,6 @@ changes in sbcl-1.0.1 relative to sbcl-1.0: x86/x86-64, rather than the previous fixed depth of 8 * bug fix: non-ascii command-line arguments are processed correctly (thanks to Yaroslav Kavenchuk) - * bug fix: TRACE :ENCAPSULATE NIL (and function end breakpoints) - work on Windows. * bug fix: non-required arguments were not passed correctly when a method defined using DEFMETHOD was called from a mop-generated method using CALL-NEXT-METHOD (reported by Pascal Costanza) @@ -31,6 +29,13 @@ changes in sbcl-1.0.1 relative to sbcl-1.0: * optimization: the FIND and POSITION family of sequence functions are significantly faster on arrays whose element types have been declared. + * improvements to the Windows port: + ** Intermittent heap corruption problems have been fixed. (thanks + to Alastair Bridgewater) + ** TRACE :ENCAPSULATE NIL (and function end breakpoints) + work on Windows. + ** Lisp is able to unwind foreing exception frames from alien + callbacks. (thanks to Alastair Bridgewater) changes in sbcl-1.0 relative to sbcl-0.9.18: * improvement: experimental support for threading on FreeBSD/x86. diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 07f017f..cc271d5 100644 --- a/src/assembly/x86/assem-rtns.lisp +++ b/src/assembly/x86/assem-rtns.lisp @@ -255,6 +255,21 @@ ;; 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 @@ -263,6 +278,16 @@ 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 @@ -270,4 +295,74 @@ ;; 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 + 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)))) + +;; 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 +(define-assembly-routine + (win32-unwind-tail (:return-style :none)) + () + + ;; 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 and pick up where we left off. + (inst popa) + (inst ret)) diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 9161889..b77f4ea 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -646,6 +646,8 @@ char *dirname(char *path) /* This is a manually-maintained version of ldso_stubs.S. */ +void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */ + void scratch(void) { CloseHandle(0); @@ -682,6 +684,7 @@ void scratch(void) sinh(0); strerror(42); write(0, 0, 0); + RtlUnwind(0, 0, 0, 0); #ifndef LISP_FEATURE_SB_UNICODE CreateDirectoryA(0,0); GetComputerNameA(0, 0); diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index 4619da3..288b7da 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -167,4 +167,40 @@ (error "bad note! ~A" c)))) (funcall (compile nil '(lambda () (sb-alien:make-alien sb-alien:int))))) +;;; Test case for unwinding an alien (Win32) exception frame +;;; +;;; The basic theory here is that failing to honor a win32 +;;; exception frame during stack unwinding breaks the chain. +;;; "And if / You don't love me now / You will never love me +;;; again / I can still hear you saying / You would never break +;;; the chain." If the chain is broken and another exception +;;; occurs (such as an error trap caused by an OBJECT-NOT-TYPE +;;; error), the system will kill our process. No mercy, no +;;; appeal. So, to check that we have done our job properly, we +;;; need some way to put an exception frame on the stack and then +;;; unwind through it, then trigger another exception. (FUNCALL +;;; 0) will suffice for the latter, and a simple test shows that +;;; CallWindowProc() establishes a frame and calls a function +;;; passed to it as an argument. +#+win32 +(progn + (load-shared-object "USER32") + (assert + (eq :ok + (handler-case + (tagbody + (alien-funcall + (extern-alien "CallWindowProcW" + (function unsigned-int + (* (function int)) unsigned-int + unsigned-int unsigned-int unsigned-int)) + (alien-sap + (sb-alien::alien-callback (function unsigned-int) + #'(lambda () (go up)))) + 0 0 0 0) + up + (funcall 0)) + (error () + :ok))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index e610e76..30e54e2 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.0.18" +"1.0.0.19"