From: Nikodemus Siivola Date: Wed, 25 Oct 2006 17:07:53 +0000 (+0000) Subject: 0.9.18.2: Win32 exceptions X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b43b6e70ce48d959d77f7f56be9d11aa101fdd7d;p=sbcl.git 0.9.18.2: Win32 exceptions * Floating point exceptions. * Stack exhaustion exception. * Rename FIND-INTERRUPTED-NAME to FIND-INTERRUPTED-NAME-AND-FRAME. * Commentary (questionary?) on the Win32 exception magic. * More groveling. Alert: grovel-headers.c/defconstant uses now unsigned long, not long. Works on Linux/x86, Win32, and Darwin/ppc. If breaks elsewhere then define_signed_const and define_unsigned_const needed. --- diff --git a/NEWS b/NEWS index c6ebb72..a6b1a44 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,9 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18: * improvement: floating point modes in effect are now saved in core, and restored on startup. + * improvements to the Windows port: + ** floating point exceptions are now reported correctly. + ** stack exhaustion detection works partially. changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.17: * enhancement: SB-POSIX now supports cfsetispeed(3), cfsetospeed(3), diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8dd35c9..cad8f2a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1501,7 +1501,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FDEFN-MAKUNBOUND" "OUTER-FDEFN" "%COERCE-CALLABLE-TO-FUN" "FUN-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" - "INFINITE-ERROR-PROTECT" "FIND-CALLER-NAME-AND-FRAME" + "INFINITE-ERROR-PROTECT" + "FIND-CALLER-NAME-AND-FRAME" + "FIND-INTERRUPTED-NAME-AND-FRAME" "%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE" "OUTPUT-SYMBOL-NAME" "%COERCE-NAME-TO-FUN" "INVOKE-MACROEXPAND-HOOK" "DEFAULT-STRUCTURE-PRINT" diff --git a/src/code/interr.lisp b/src/code/interr.lisp index f5b46bc..d07f23d 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -363,8 +363,8 @@ (values "" nil))))) -(defun find-interrupted-name () - (/show0 "entering FIND-INTERRUPTED-NAME") +(defun find-interrupted-name-and-frame () + (/show0 "entering FIND-INTERRUPTED-NAME-AND-FRAME") (if *finding-name* (values "" nil) (handler-case @@ -418,7 +418,7 @@ (%primitive sb!c:halt)) (multiple-value-bind (name sb!debug:*stack-top-hint*) - (find-interrupted-name) + (find-interrupted-name-and-frame) (/show0 "back from FIND-INTERRUPTED-NAME") (let ((fp (int-sap (sb!vm:context-register alien-context sb!vm::cfp-offset))) diff --git a/src/code/target-exception.lisp b/src/code/target-exception.lisp index 8e25dc0..f01acf7 100644 --- a/src/code/target-exception.lisp +++ b/src/code/target-exception.lisp @@ -9,7 +9,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!UNIX") +(in-package "SB!WIN32") ;;; ;;; An awful lot of this stuff is stubbed out for now. We basically @@ -41,13 +41,40 @@ (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) |# -;;; Actual exception handler. We hit something the runtime doesn't -;;; want to or know how to deal with (that is, not a sigtrap or gc -;;; wp violation), so it calls us here. +;;; Map Windows Exception code to condition names +(defvar *exception-code-map* + (list + ;; Floating point exceptions + (cons +exception-flt-divide-by-zero+ 'division-by-zero) + (cons +exception-flt-invalid-operation+ 'floating-point-invalid-operation) + (cons +exception-flt-underflow+ 'floating-point-underflow) + (cons +exception-flt-overflow+ 'floating-point-overflow) + (cons +exception-flt-inexact-result+ 'floating-point-inexact) + (cons +exception-flt-denormal-operand+ 'floating-point-exception) + (cons +exception-flt-stack-check+ 'floating-point-exception) + (cons +exception-stack-overflow+ 'sb!kernel::control-stack-exhausted))) + +(define-alien-type () + (struct exception-record + (exception-code dword) + (exception-flags dword) + (exception-record system-area-pointer) + (exception-address system-area-pointer) + (number-parameters dword) + (exception-information system-area-pointer))) -(defun sb!kernel:handle-win32-exception (context exception-record) - (error "An exception occured! Context ~A, exception-record ~A." - context exception-record)) +;;; Actual exception handler. We hit something the runtime doesn't +;;; want to or know how to deal with (that is, not a sigtrap or gc wp +;;; violation), so it calls us here. +(defun sb!kernel:handle-win32-exception (context-sap exception-record-sap) + (let* ((record (deref (sap-alien exception-record-sap (* (struct exception-record))))) + (code (slot record 'exception-code)) + (condition-name (cdr (assoc code *exception-code-map*))) + (sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) + (if condition-name + (error condition-name) + (error "An exception occurred in context ~S: ~S. (Exception code: ~S)" + context-sap exception-record-sap code)))) ;;;; etc. diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 1749966..3689a21 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -270,6 +270,12 @@ in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) } boolean +is_linkage_table_addr(os_vm_address_t addr) +{ + return in_range_p(addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_END); +} + +boolean is_valid_lisp_addr(os_vm_address_t addr) { struct thread *th; @@ -321,17 +327,16 @@ EXCEPTION_DISPOSITION sigtrap_emulator(CONTEXT *context, struct lisp_exception_frame *exception_frame) { if (*((char *)context->Eip + 1) == trap_ContextRestore) { - /* - * This is the cleanup for what is immediately below, and + /* This is the cleanup for what is immediately below, and * for the generic exception handling further below. We * have to memcpy() the original context (emulated sigtrap - * or normal exception) over our context and resume it. - */ + * or normal exception) over our context and resume it. */ memcpy(context, &exception_frame->context, sizeof(CONTEXT)); return ExceptionContinueExecution; - } else { /* Not a trap_ContextRestore, must be a sigtrap. */ - /* sigtrap_trampoline is defined in x86-assem.S. */ + } else { + /* Not a trap_ContextRestore, must be a sigtrap. + * sigtrap_trampoline is defined in x86-assem.S. */ extern void sigtrap_trampoline; /* @@ -340,8 +345,7 @@ EXCEPTION_DISPOSITION sigtrap_emulator(CONTEXT *context, */ context->Eip++; - /* - * We're not on an alternate stack like we would be in some + /* We're not on an alternate stack like we would be in some * other operating systems, and we don't want to risk leaking * any important resources if we throw out of the sigtrap * handler, so we need to copy off our context to a "safe" @@ -359,9 +363,16 @@ EXCEPTION_DISPOSITION sigtrap_emulator(CONTEXT *context, * I can come up with for this, however, involves a stack * overflow occuring at just the wrong time (which makes one * wonder how stack overflow exceptions even happen, given - * that we don't switch stacks for exception processing...) - */ + * that we don't switch stacks for exception processing...) */ memcpy(&exception_frame->context, context, sizeof(CONTEXT)); + + /* FIXME: Why do we save the old EIP in EAX? The sigtrap_trampoline + * pushes it into stack, but the sigtrap_wrapper where the trampoline + * goes ignores it, and after the wrapper we hit the trap_ContextRestore, + * which nukes the whole context with the original one? + * + * Am I misreading this, or is the EAX here and in the + * trampoline superfluous? --NS 20061024 */ context->Eax = context->Eip; context->Eip = (unsigned long)&sigtrap_trampoline; @@ -381,7 +392,6 @@ void sigtrap_wrapper(void) * wrappers. Once it is installed there, it can probably be * removed from here. */ - extern void sigtrap_handler(int signal, siginfo_t *info, void *context); /* volatile struct { */ @@ -411,33 +421,30 @@ EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record, /* For EXCEPTION_ACCESS_VIOLATION only. */ void *fault_address = (void *)exception_record->ExceptionInformation[1]; - + if (exception_record->ExceptionCode == EXCEPTION_BREAKPOINT) { /* Pick off sigtrap case first. */ return sigtrap_emulator(context, exception_frame); - } else if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION && - (is_valid_lisp_addr(fault_address) || - /* the linkage table does not contain valid lisp - * objects, but is also committed on-demand here - */ - in_range_p(fault_address, LINKAGE_TABLE_SPACE_START, - LINKAGE_TABLE_SPACE_END))) { - /* Pick off GC-related memory fault next. */ - MEMORY_BASIC_INFORMATION mem_info; - - if (!VirtualQuery(fault_address, &mem_info, sizeof mem_info)) { - fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError()); - lose("handle_exception: VirtualQuery failure"); - } - - if (mem_info.State == MEM_RESERVE) { - /* First use new page, lets get some memory for it. */ - if (!VirtualAlloc(mem_info.BaseAddress, os_vm_page_size, - MEM_COMMIT, PAGE_EXECUTE_READWRITE)) { - fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError()); + } + else if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION && + (is_valid_lisp_addr(fault_address) || + is_linkage_table_addr(fault_address))) { + /* Pick off GC-related memory fault next. */ + MEMORY_BASIC_INFORMATION mem_info; + + if (!VirtualQuery(fault_address, &mem_info, sizeof mem_info)) { + fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError()); + lose("handle_exception: VirtualQuery failure"); + } + + if (mem_info.State == MEM_RESERVE) { + /* First use new page, lets get some memory for it. */ + if (!VirtualAlloc(mem_info.BaseAddress, os_vm_page_size, + MEM_COMMIT, PAGE_EXECUTE_READWRITE)) { + fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError()); lose("handle_exception: VirtualAlloc failure"); - + } else { /* * Now, if the page is supposedly write-protected and this @@ -462,46 +469,49 @@ EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record, /* All else failed, drop through to the lisp-side exception handler. */ } - + /* * If we fall through to here then we need to either forward * the exception to the lisp-side exception handler if it's * set up, or drop to LDB. */ - + if (internal_errors_enabled) { /* exception_trampoline is defined in x86-assem.S. */ extern void exception_trampoline; - /* - * We're making the somewhat arbitrary decision that - * having internal errors enabled means that lisp has - * sufficient marbles to be able to handle exceptions. - * - * Exceptions aren't supposed to happen during cold - * init or reinit anyway. - */ - - /* + /* We're making the somewhat arbitrary decision that having + * internal errors enabled means that lisp has sufficient + * marbles to be able to handle exceptions, but xceptions + * aren't supposed to happen during cold init or reinit + * anyway. + * * We use the same mechanism as the sigtrap emulator above * with just a couple changes. We obviously use a different * trampoline and wrapper function, we kill out any live * floating point exceptions, and we save off the exception - * record as well as the context. - */ + * record as well as the context. */ - /* Save off context and exception information */ + /* Save off context and exception information */ memcpy(&exception_frame->context, context, sizeof(CONTEXT)); memcpy(&exception_frame->exception, exception_record, sizeof(EXCEPTION_RECORD)); - /* Set up to activate trampoline when we return */ + /* Set up to activate trampoline when we return + * + * FIXME: Why do we save the old EIP in EAX? The + * exception_trampoline pushes it into stack, but the wrapper + * where the trampoline goes ignores it, and then the wrapper + * unwinds from Lisp... WTF? + * + * Am I misreading this, or is the EAX here and in the + * trampoline superfluous? --NS 20061024 */ context->Eax = context->Eip; context->Eip = (unsigned long)&exception_trampoline; /* Make sure a floating-point trap doesn't kill us */ context->FloatSave.StatusWord &= ~0x3f; - /* And return */ + /* And return. */ return ExceptionContinueExecution; } @@ -549,8 +559,10 @@ void handle_win32_exception_wrapper(void) funcall2(SymbolFunction(HANDLE_WIN32_EXCEPTION), context_sap, exception_record_sap); + /* FIXME: These never happen, as the Lisp-side call is + * to an ERROR, which means we must do a non-local exit + */ undo_fake_foreign_function_call(&context); - memcpy(&frame->context, &context, sizeof(CONTEXT)); } diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 3cdee8a..12476d9 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -51,18 +51,18 @@ printf("(define-alien-type " lispname " (%s %d))\n", (((foo=-1)<0) ? "sb!alien:signed" : "unsigned"), (8 * (sizeof foo))); } void -defconstant(char* lisp_name, long unix_number) +defconstant(char* lisp_name, unsigned long unix_number) { - printf("(defconstant %s %ld) ; #x%lx\n", + printf("(defconstant %s %lu) ; #x%lx\n", lisp_name, unix_number, unix_number); } -void deferrno(char* lisp_name, long unix_number) +void deferrno(char* lisp_name, unsigned long unix_number) { defconstant(lisp_name, unix_number); } -void defsignal(char* lisp_name, long unix_number) +void defsignal(char* lisp_name, unsigned long unix_number) { defconstant(lisp_name, unix_number); } @@ -149,6 +149,16 @@ main(int argc, char *argv[]) defconstant ("CSIDL_FLAG_CREATE", CSIDL_FLAG_CREATE); defconstant ("CSIDL_FLAG_MASK", CSIDL_FLAG_MASK); + printf(";;; Exception codes\n"); + defconstant("+exception-flt-divide-by-zero+", EXCEPTION_FLT_DIVIDE_BY_ZERO); + defconstant("+exception-flt-invalid-operation+", EXCEPTION_FLT_INVALID_OPERATION); + defconstant("+exception-flt-underflow+", EXCEPTION_FLT_UNDERFLOW); + defconstant("+exception-flt-overflow+", EXCEPTION_FLT_OVERFLOW); + defconstant("+exception-flt-inexact-result+", EXCEPTION_FLT_INEXACT_RESULT); + defconstant("+exception-flt-denormal-operand+", EXCEPTION_FLT_DENORMAL_OPERAND); + defconstant("+exception-flt-stack-check+", EXCEPTION_FLT_STACK_CHECK); + defconstant("+exception-stack-overflow+", EXCEPTION_STACK_OVERFLOW); + printf(";;; FormatMessage\n"); defconstant ("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER); @@ -168,6 +178,7 @@ main(int argc, char *argv[]) DEFTYPE("dword", DWORD); DEFTYPE("bool", BOOL); DEFTYPE("uint", UINT); + DEFTYPE("ulong", ULONG); /* FIXME: SB-UNIX and SB-WIN32 really need to be untangled. */ printf("(in-package \"SB!UNIX\")\n\n"); diff --git a/version.lisp-expr b/version.lisp-expr index f3d58a4..1499e00 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,5 +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".) -"0.9.18.1" - +"0.9.18.2"