0.9.18.6: Win32 get-internal-real-time improved
[sbcl.git] / src / runtime / win32-os.c
index 9b78fd5..9f945e8 100644 (file)
@@ -26,6 +26,7 @@
  * yet.
  */
 
+#include <malloc.h>
 #include <stdio.h>
 #include <sys/param.h>
 #include <sys/file.h>
@@ -146,7 +147,7 @@ os_validate(os_vm_address_t addr, os_vm_size_t len)
         /* the simple case first */
         os_vm_address_t real_addr;
         if (!(real_addr = VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE))) {
-            perror("VirtualAlloc");
+            fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
             return 0;
         }
 
@@ -154,7 +155,7 @@ os_validate(os_vm_address_t addr, os_vm_size_t len)
     }
 
     if (!VirtualQuery(addr, &mem_info, sizeof mem_info)) {
-        perror("VirtualQuery");
+        fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError());
         return 0;
     }
 
@@ -166,7 +167,7 @@ os_validate(os_vm_address_t addr, os_vm_size_t len)
     }
 
     if (!VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)? MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)) {
-        perror("VirtualAlloc");
+        fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
         return 0;
     }
 
@@ -192,7 +193,7 @@ void
 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
 {
     if (!VirtualFree(addr, len, MEM_DECOMMIT)) {
-        perror("VirtualFree");
+        fprintf(stderr, "VirtualFree: 0x%lx.\n", GetLastError());
     }
 }
 
@@ -212,11 +213,13 @@ os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
 {
     os_vm_size_t count;
 
+#if 0
     fprintf(stderr, "os_map: %d, 0x%x, %p, 0x%x.\n", fd, offset, addr, len);
     fflush(stderr);
+#endif
 
     if (!VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) {
-        perror("VirtualAlloc");
+        fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
         lose("os_map: VirtualAlloc failure");
     }
 
@@ -268,6 +271,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;
@@ -319,17 +328,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;
 
         /*
@@ -338,8 +346,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"
@@ -357,9 +364,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;
 
@@ -379,7 +393,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 { */
@@ -414,13 +427,10 @@ EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record,
         /* 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))) {
+    }
+    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;
 
@@ -471,35 +481,38 @@ EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record,
         /* 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.
+        /* 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.
          *
-         * Exceptions 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 */
         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;
     }
 
@@ -547,8 +560,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));
 }
 
@@ -615,64 +630,62 @@ char *dirname(char *path)
 
 void scratch(void)
 {
-    strerror(42);
-    asin(0);
+    CloseHandle(0);
+    FlushConsoleInputBuffer(0);
+    FormatMessageA(0, 0, 0, 0, 0, 0, 0);
+    FreeLibrary(0);
+    GetACP();
+    GetConsoleCP();
+    GetConsoleOutputCP();
+    GetCurrentProcess();
+    GetExitCodeProcess(0, 0);
+    GetLastError();
+    GetOEMCP();
+    GetProcAddress(0, 0);
+    GetProcessTimes(0, 0, 0, 0, 0);
+    GetSystemTimeAsFileTime(0);
+    LoadLibrary(0);
+    LocalFree(0);
+    PeekConsoleInput(0, 0, 0, 0);
+    PeekNamedPipe(0, 0, 0, 0, 0, 0);
+    ReadFile(0, 0, 0, 0, 0);
+    Sleep(0);
+    WriteFile(0, 0, 0, 0, 0);
+    _get_osfhandle(0);
+    _pipe(0,0,0);
+    access(0,0);
     acos(0);
-    sinh(0);
+    asin(0);
+    close(0);
     cosh(0);
+    dup(0);
     hypot(0, 0);
+    isatty(0);
+    sinh(0);
+    strerror(42);
     write(0, 0, 0);
-    close(0);
-    #ifndef LISP_FEATURE_SB_UNICODE
-      MoveFileA(0,0);
-    #else
-      MoveFileW(0,0);
-    #endif
-    #ifndef LISP_FEATURE_SB_UNICODE
-      GetCurrentDirectoryA(0,0);
-    #else
-      GetCurrentDirectoryW(0,0);
-    #endif
-    dup(0);
-    LoadLibrary(0);
-    GetProcAddress(0, 0);
-    FreeLibrary(0);
     #ifndef LISP_FEATURE_SB_UNICODE
       CreateDirectoryA(0,0);
+      GetComputerNameA(0, 0);
+      GetCurrentDirectoryA(0,0);
+      GetEnvironmentVariableA(0, 0, 0);
+      GetVersionExA(0);
+      MoveFileA(0,0);
+      SHGetFolderPathA(0, 0, 0, 0, 0);
+      SetCurrentDirectoryA(0);
+      SetEnvironmentVariableA(0, 0);
     #else
       CreateDirectoryW(0,0);
-    #endif
-    _pipe(0,0,0);
-    isatty(0);
-    access(0,0);
-    GetLastError();
-    FormatMessageA(0, 0, 0, 0, 0, 0, 0);
-    #ifdef LISP_FEATURE_SB_UNICODE
       FormatMessageW(0, 0, 0, 0, 0, 0, 0);
-    #endif
-    _get_osfhandle(0);
-    ReadFile(0, 0, 0, 0, 0);
-    WriteFile(0, 0, 0, 0, 0);
-    PeekNamedPipe(0, 0, 0, 0, 0, 0);
-    FlushConsoleInputBuffer(0);
-    PeekConsoleInput(0, 0, 0, 0);
-    Sleep(0);
-    #ifndef LISP_FEATURE_SB_UNICODE
-      SHGetFolderPathA(0, 0, 0, 0, 0);
-    #else
-      SHGetFolderPathW(0, 0, 0, 0, 0);
-    #endif
-    GetACP();
-    GetOEMCP();
-    LocalFree(0);
-    #ifndef LISP_FEATURE_SB_UNICODE
-      GetEnvironmentVariableA(0, 0, 0);
-    #else
+      GetComputerNameW(0, 0);
+      GetCurrentDirectoryW(0,0);
       GetEnvironmentVariableW(0, 0, 0);
+      GetVersionExW(0);
+      MoveFileW(0,0);
+      SHGetFolderPathW(0, 0, 0, 0, 0);
+      SetCurrentDirectoryW(0);
+      SetEnvironmentVariableW(0, 0);
     #endif
-    GetConsoleCP();
-    GetConsoleOutputCP();
-    GetExitCodeProcess(0, 0);
 }
 
 char *