X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fwin32-os.c;h=49358a14370c9f93a9d61dd353c2f1755a7cd51c;hb=37d3828773e2f847bb1ed7522b0af4fb8e736fc8;hp=21aee3858815f9e2e883a91452a7be5d51fa30b7;hpb=ace42c658eab1d7965763fab123b2d6bd065d1d7;p=sbcl.git

diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c
index 21aee38..49358a1 100644
--- a/src/runtime/win32-os.c
+++ b/src/runtime/win32-os.c
@@ -680,6 +680,54 @@ void os_preinit()
 }
 #endif  /* LISP_FEATURE_SB_THREAD */
 
+
+#ifdef LISP_FEATURE_X86_64
+/* Windows has 32-bit 'longs', so printf...%lX (and other %l patterns) doesn't
+ * work well with address-sized values, like it's done all over the place in
+ * SBCL. And msvcrt uses I64, not LL, for printing long longs.
+ *
+ * I've already had enough search/replace with longs/words/intptr_t for today,
+ * so I prefer to solve this problem with a format string translator. */
+
+/* There is (will be) defines for printf and friends. */
+
+static int translating_vfprintf(FILE*stream, const char *fmt, va_list args)
+{
+    char translated[1024];
+    int i=0, delta = 0;
+
+    while (fmt[i-delta] && i<sizeof(translated)-1) {
+        if((fmt[i-delta]=='%')&&
+           (fmt[i-delta+1]=='l')) {
+            translated[i++]='%';
+            translated[i++]='I';
+            translated[i++]='6';
+            translated[i++]='4';
+            delta += 2;
+        } else {
+            translated[i]=fmt[i-delta];
+            ++i;
+        }
+    }
+    translated[i++]=0;
+    return vfprintf(stream,translated,args);
+}
+
+int printf(const char*fmt,...)
+{
+    va_list args;
+    va_start(args,fmt);
+    return translating_vfprintf(stdout,fmt,args);
+}
+int fprintf(FILE*stream,const char*fmt,...)
+{
+    va_list args;
+    va_start(args,fmt);
+    return translating_vfprintf(stream,fmt,args);
+}
+
+#endif
+
 int os_number_of_processors = 1;
 
 BOOL WINAPI CancelIoEx(HANDLE handle, LPOVERLAPPED overlapped);
@@ -1036,7 +1084,6 @@ c_level_backtrace(const char* header, int depth)
 #endif
 
 
-#if defined(LISP_FEATURE_X86)
 static int
 handle_single_step(os_context_t *ctx)
 {
@@ -1045,12 +1092,10 @@ handle_single_step(os_context_t *ctx)
 
     /* We are doing a displaced instruction. At least function
      * end breakpoints use this. */
-    WITH_GC_AT_SAFEPOINTS_ONLY () /* Todo: Is it really gc-unsafe? */
-        restore_breakpoint_from_single_step(ctx);
+    restore_breakpoint_from_single_step(ctx);
 
     return 0;
 }
-#endif
 
 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_ILLEGAL_INSTRUCTION
@@ -1064,7 +1109,7 @@ static int
 handle_breakpoint_trap(os_context_t *ctx, struct thread* self)
 {
 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
-    if (((unsigned short *)((ctx->win32_context)->Eip))[0] != 0x0b0f)
+    if (((unsigned short *)*os_context_pc_addr(ctx))[0] != 0x0b0f)
         return -1;
 #endif
 
@@ -1328,6 +1373,13 @@ handle_exception(EXCEPTION_RECORD *exception_record,
     context.sigmask = self ? self->os_thread->blocked_signal_set : 0;
 #endif
 
+    os_context_register_t oldbp = NULL;
+    if (self) {
+        oldbp = self ? self->carried_base_pointer : 0;
+        self->carried_base_pointer
+            = (os_context_register_t) voidreg(win32_context, bp);
+    }
+
     /* For EXCEPTION_ACCESS_VIOLATION only. */
     void *fault_address = (void *)exception_record->ExceptionInformation[1];
 
@@ -1358,11 +1410,9 @@ handle_exception(EXCEPTION_RECORD *exception_record,
         rc = handle_breakpoint_trap(ctx, self);
         break;
 
-#if defined(LISP_FEATURE_X86)
     case EXCEPTION_SINGLE_STEP:
         rc = handle_single_step(ctx);
         break;
-#endif
 
     default:
         rc = -1;
@@ -1372,11 +1422,53 @@ handle_exception(EXCEPTION_RECORD *exception_record,
         /* All else failed, drop through to the lisp-side exception handler. */
         signal_internal_error_or_lose(ctx, exception_record, fault_address);
 
+    if (self)
+        self->carried_base_pointer = oldbp;
+
     errno = lastErrno;
     SetLastError(lastError);
     return ExceptionContinueExecution;
 }
 
+#ifdef LISP_FEATURE_X86_64
+
+#define RESTORING_ERRNO()                                       \
+    int sbcl__lastErrno = errno;                                \
+    RUN_BODY_ONCE(restoring_errno, errno = sbcl__lastErrno)
+
+LONG
+veh(EXCEPTION_POINTERS *ep)
+{
+    EXCEPTION_DISPOSITION disp;
+
+    RESTORING_ERRNO() {
+        if (!pthread_self())
+            return EXCEPTION_CONTINUE_SEARCH;
+    }
+
+    disp = handle_exception(ep->ExceptionRecord,0,ep->ContextRecord,0);
+
+    switch (disp)
+    {
+    case ExceptionContinueExecution:
+        return EXCEPTION_CONTINUE_EXECUTION;
+    case ExceptionContinueSearch:
+        return EXCEPTION_CONTINUE_SEARCH;
+    default:
+        fprintf(stderr,"Exception handler is mad\n");
+        ExitProcess(0);
+    }
+}
+#endif
+
+os_context_register_t
+carry_frame_pointer(os_context_register_t default_value)
+{
+    struct thread* self = arch_os_get_current_thread();
+    os_context_register_t bp = self->carried_base_pointer;
+    return bp ? bp : default_value;
+}
+
 void
 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
 {
@@ -1970,8 +2062,6 @@ win32_unix_read(HANDLE handle, void * buf, int count)
     return read_bytes;
 }
 
-void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
-
 /* We used to have a scratch() function listing all symbols needed by
  * Lisp.  Much rejoicing commenced upon its removal.  However, I would
  * like cold init to fail aggressively when encountering unused symbols.