update to current master againwip/T13904

8 files changed, 303 insertions, 53 deletions

diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c
index 3d283b0162..545a76a004 100644
--- a/rts/win32/ConsoleHandler.c
+++ b/rts/win32/ConsoleHandler.c
@@ -183,13 +183,15 @@ void startSignalHandlers(Capability *cap)
     handler = deRefStablePtr((StgStablePtr)console_handler);
     while (stg_pending_events > 0) {
         stg_pending_events--;
-        scheduleThread(cap,
+        StgTSO *t =
             createIOThread(cap,
-                RtsFlags.GcFlags.initialStkSize,
-                rts_apply(cap,
-                    (StgClosure *)handler,
-                    rts_mkInt(cap,
-                        stg_pending_buf[stg_pending_events]))));
+                           RtsFlags.GcFlags.initialStkSize,
+                           rts_apply(cap,
+                                     (StgClosure *)handler,
+                                     rts_mkInt(cap,
+                                               stg_pending_buf[stg_pending_events])));
+        scheduleThread(cap, t);
+        labelThread(cap, t, "signal handler thread");
     }
 
     RELEASE_LOCK(&sched_mutex);
@@ -197,18 +199,6 @@ void startSignalHandlers(Capability *cap)
 }
 #endif /* !THREADED_RTS */
 
-/*
- * Function: markSignalHandlers()
- *
- * Evacuate the handler stack. _Assumes_ that console event delivery
- * has already been blocked.
- */
-void markSignalHandlers (evac_fn evac STG_UNUSED, void *user STG_UNUSED)
-{
-    // nothing to mark; the console handler is a StablePtr which is
-    // already treated as a root by the GC.
-}
-
 
 /*
  * Function: generic_handler()
diff --git a/rts/win32/GetTime.c b/rts/win32/GetTime.c
index 90c0d0d244..014a676e99 100644
--- a/rts/win32/GetTime.c
+++ b/rts/win32/GetTime.c
@@ -84,6 +84,11 @@ getMonotonicNSec()
     }
     else // fallback to GetTickCount
     {
+        // TODO: Remove this code path, it cannot be taken because
+        // `QueryPerformanceFrequency` cannot fail on Windows >= XP
+        // and GHC no longer supports Windows <= XP.
+        // See https://ghc.haskell.org/trac/ghc/ticket/14233
+
         // NOTE: GetTickCount is a 32-bit millisecond value, so it wraps around
         // every 49 days.
         DWORD count = GetTickCount();
diff --git a/rts/win32/IOManager.c b/rts/win32/IOManager.c
index c5cae75366..f155180ef3 100644
--- a/rts/win32/IOManager.c
+++ b/rts/win32/IOManager.c
@@ -435,10 +435,12 @@ AddIORequest ( int   fd,
                char* buffer,
                CompletionProc onCompletion)
 {
+    ASSERT(ioMan);
+
     WorkItem* wItem    = (WorkItem*)malloc(sizeof(WorkItem));
-    unsigned int reqID;
-    if (!ioMan || !wItem) return 0;
-    reqID = ioMan->requestID++;
+    if (!wItem) return 0;
+
+    unsigned int reqID = ioMan->requestID++;
 
     /* Fill in the blanks */
     wItem->workKind     = ( isSocket   ? WORKER_FOR_SOCKET : 0 ) |
@@ -464,10 +466,12 @@ BOOL
 AddDelayRequest ( HsInt          usecs,
                   CompletionProc onCompletion)
 {
+    ASSERT(ioMan);
+
     WorkItem* wItem = (WorkItem*)malloc(sizeof(WorkItem));
-    unsigned int reqID;
-    if (!ioMan || !wItem) return false;
-    reqID = ioMan->requestID++;
+    if (!wItem) return false;
+
+    unsigned int reqID = ioMan->requestID++;
 
     /* Fill in the blanks */
     wItem->workKind     = WORKER_DELAY;
@@ -489,10 +493,12 @@ AddProcRequest ( void* proc,
                  void* param,
                  CompletionProc onCompletion)
 {
+    ASSERT(ioMan);
+
     WorkItem* wItem = (WorkItem*)malloc(sizeof(WorkItem));
-    unsigned int reqID;
-    if (!ioMan || !wItem) return false;
-    reqID = ioMan->requestID++;
+    if (!wItem) return false;
+
+    unsigned int reqID = ioMan->requestID++;
 
     /* Fill in the blanks */
     wItem->workKind     = WORKER_DO_PROC;
diff --git a/rts/win32/OSMem.c b/rts/win32/OSMem.c
index c67b95be82..c62ee3b7a4 100644
--- a/rts/win32/OSMem.c
+++ b/rts/win32/OSMem.c
@@ -458,7 +458,7 @@ void *osReserveHeapMemory (void *startAddress, W_ *len)
             sysErrorBelch(
                 "osReserveHeapMemory: VirtualAlloc MEM_RESERVE %llu bytes \
                 at address %p bytes failed",
-                len + MBLOCK_SIZE, startAddress);
+                *len + MBLOCK_SIZE, startAddress);
         }
         stg_exit(EXIT_FAILURE);
     }
@@ -499,6 +499,11 @@ void osReleaseHeapMemory (void)
 
 #endif
 
+bool osBuiltWithNumaSupport(void)
+{
+    return true;
+}
+
 bool osNumaAvailable(void)
 {
     return osNumaNodes() > 1;
@@ -510,9 +515,18 @@ uint32_t osNumaNodes(void)
     static ULONG numNumaNodes = 0;
 
     /* Cache the amount of NUMA nodes. */
-    if (!numNumaNodes && !GetNumaHighestNodeNumber(&numNumaNodes))
+    if (!numNumaNodes)
     {
-        numNumaNodes = 1;
+        if (GetNumaHighestNodeNumber(&numNumaNodes))
+        {
+            // GetNumaHighestNodeNumber returns the highest node number
+            // i.e: 0 for a non-NUMA system, and >0 for a NUMA system, so add a 1.
+            numNumaNodes += 1;
+        }
+        else
+        {
+            numNumaNodes = 1;
+        }
     }
 
     return numNumaNodes;
@@ -520,12 +534,12 @@ uint32_t osNumaNodes(void)
 
 uint64_t osNumaMask(void)
 {
-    uint64_t numaMask;
-    if (!GetNumaNodeProcessorMask(0, &numaMask))
-    {
-        return 1;
+    // the concept of a numa node mask (c.f. numa_get_mems_allowed on POSIX)
+    // doesn't exist on Windows. Thus, all nodes are allowed.
+    if (osNumaNodes() > sizeof(StgWord)*8) {
+        barf("osNumaMask: too many NUMA nodes (%d)", osNumaNodes());
     }
-    return numaMask;
+    return (1 << osNumaNodes()) - 1;
 }
 
 void osBindMBlocksToNode(
diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c
index ad4234066b..c67d621bc2 100644
--- a/rts/win32/OSThreads.c
+++ b/rts/win32/OSThreads.c
@@ -236,6 +236,7 @@ forkOS_createThreadWrapper ( void * entry )
     cap = rts_lock();
     rts_evalStableIO(&cap, (HsStablePtr) entry, NULL);
     rts_unlock(cap);
+    rts_done();
     return 0;
 }
 
@@ -577,9 +578,8 @@ void setThreadNode (uint32_t node)
 {
     if (osNumaAvailable())
     {
-        StgWord mask = 0;
-        mask |= 1 << node;
-        if (!SetThreadAffinityMask(GetCurrentThread(), mask))
+        uint64_t mask = 0;
+        if (!GetNumaNodeProcessorMask(node, &mask) && !SetThreadAffinityMask(GetCurrentThread(), mask))
         {
             sysErrorBelch(
                 "setThreadNode: Error setting affinity of thread to NUMA node `%u': %lu.",
diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def
index 496893a722..d4ec1fab0a 100644
--- a/rts/win32/libHSbase.def
+++ b/rts/win32/libHSbase.def
@@ -42,6 +42,7 @@ EXPORTS
         base_GHCziIOziException_cannotCompactPinned_closure
         base_GHCziIOziException_cannotCompactMutable_closure
 
+	base_ControlziExceptionziBase_absentSumFieldError_closure
 	base_ControlziExceptionziBase_nonTermination_closure
 	base_ControlziExceptionziBase_nestedAtomically_closure
 	base_GHCziEventziThread_blockedOnBadFD_closure
diff --git a/rts/win32/veh_excn.c b/rts/win32/veh_excn.c
index d925ad8919..2d9de52199 100644
--- a/rts/win32/veh_excn.c
+++ b/rts/win32/veh_excn.c
@@ -5,16 +5,79 @@
 * Error Handling implementations for windows
 *
 * ---------------------------------------------------------------------------*/
-
+#define UNICODE 1
 #include "Rts.h"
 #include "ghcconfig.h"
 #include "veh_excn.h"
+#include "LinkerInternals.h"
 #include <assert.h>
+#include <stdbool.h>
+#include <dbghelp.h>
+#include <shellapi.h>
+#include <shlobj.h>
+#include <wchar.h>
+#include <windows.h>
+#include <stdio.h>
+#include <excpt.h>
+#include <inttypes.h>
+#include <dbghelp.h>
+#include <signal.h>
 
 /////////////////////////////////
 // Exception / signal handlers.
 /////////////////////////////////
 
+/*
+  SEH (Structured Error Handler) on Windows is quite tricky. On x86 SEHs are
+  stack based and are stored in FS[0] of each thread. Which means every time we
+  spawn an OS thread we'd have to set up the error handling. However on x64 it's
+  table based and memory region based. e.g. you register a handler for a
+  particular memory range. This means that we'd have to register handlers for
+  each block of code we load externally or generate internally ourselves.
+
+  In Windows XP VEH (Vectored Exception Handler) and VCH (Vectored Continue
+  Handler) were added. Both of these are global/process wide handlers, the
+  former handling all exceptions and the latter handling only exceptions which
+  we're trying to recover from, e.g. a handler returned
+  EXCEPTION_CONTINUE_EXECUTION.
+
+  And lastly you have top level exception filters, which are also process global
+  but the problem here is that you can only have one, and setting this removes
+  the previous ones. The chain of exception handling looks like
+
+                    [  Vectored Exception Handler  ]
+                                |
+                    [ Structured Exception Handler ]
+                                |
+                    [      Exception Filters       ]
+                                |
+                    [  Vectored Continue Handler   ]
+
+  To make things more tricky, the exception handlers handle both hardware and
+  software exceptions Which means previously when we registered VEH handlers
+  we would also trap software exceptions. Which means when haskell code was
+  loaded in a C++ or C# context we would swallow exceptions and terminate in
+  contexes that normally the runtime should be able to continue on, e.g. you
+  could be handling the segfault in your C++ code, or the div by 0.
+
+  We could not handle these exceptions, but GHCi would just die a horrible death
+  then on normal Haskell only code when such an exception occurs.
+
+  So instead, we'll move to Continue handler, to run as late as possible, and
+  also register a filter which calls any existing filter, and then runs the
+  continue handlers, we then also only run as the last continue handler so we
+  don't supercede any other VCH handlers.
+
+  Lastly we'll also provide a way for users to disable the exception handling
+  entirely so even if the new approach doesn't solve the issue they can work
+  around it. After all, I don't expect any interpreted code if you are running
+  a haskell dll.
+
+  For a detailed analysis see
+  https://reverseengineering.stackexchange.com/questions/14992/what-are-the-vectored-continue-handlers
+  and https://www.gamekiller.net/threads/vectored-exception-handler.3237343/
+  */
+
 // Define some values for the ordering of VEH Handlers:
 // - CALL_FIRST means call this exception handler first
 // - CALL_LAST means call this exception handler last
@@ -28,11 +91,19 @@
 
 // Registered exception handler
 PVOID __hs_handle = NULL;
+LPTOP_LEVEL_EXCEPTION_FILTER oldTopFilter = NULL;
+bool crash_dump = false;
+bool filter_called = false;
 
 long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
 {
-    long action = EXCEPTION_CONTINUE_SEARCH;
+    if (!crash_dump && filter_called)
+      return EXCEPTION_CONTINUE_EXECUTION;
+
+    long action   = EXCEPTION_CONTINUE_SEARCH;
+    int exit_code = EXIT_FAILURE;
     ULONG_PTR what;
+    fprintf (stderr, "\n");
 
     // When the system unwinds the VEH stack after having handled an excn,
     // return immediately.
@@ -42,21 +113,28 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
         switch (exception_data->ExceptionRecord->ExceptionCode) {
             case EXCEPTION_FLT_DIVIDE_BY_ZERO:
             case EXCEPTION_INT_DIVIDE_BY_ZERO:
-                fprintf(stdout, "divide by zero\n");
+                fprintf(stderr, "divide by zero\n");
                 action = EXCEPTION_CONTINUE_EXECUTION;
+                exit_code = SIGFPE;
                 break;
             case EXCEPTION_STACK_OVERFLOW:
-                fprintf(stdout, "C stack overflow in generated code\n");
+                fprintf(stderr, "C stack overflow in generated code\n");
                 action = EXCEPTION_CONTINUE_EXECUTION;
                 break;
             case EXCEPTION_ACCESS_VIOLATION:
                 what = exception_data->ExceptionRecord->ExceptionInformation[0];
-                fprintf(stdout, "Access violation in generated code"
-                                " when %s %p\n"
-                                , what == 0 ? "reading" : what == 1 ? "writing" : what == 8 ? "executing data at" : "?"
-                                , (void*) exception_data->ExceptionRecord->ExceptionInformation[1]
+                fprintf(stderr, "Access violation in generated code"
+                                " when %s 0x%" PRIxPTR "\n"
+                                , what == 0 ? "reading"
+                                : what == 1 ? "writing"
+                                : what == 8 ? "executing data at"
+                                :             "?"
+                                , (uintptr_t) exception_data
+                                                ->ExceptionRecord
+                                                ->ExceptionInformation[1]
                                 );
                 action = EXCEPTION_CONTINUE_EXECUTION;
+                exit_code = SIGSEGV;
                 break;
             default:;
         }
@@ -66,40 +144,191 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
         // But the correct action is still to exit as fast as possible.
         if (EXCEPTION_CONTINUE_EXECUTION == action)
         {
-            fflush(stdout);
-            stg_exit(EXIT_FAILURE);
+            fflush(stderr);
+            generateStack (exception_data);
+            generateDump (exception_data);
+            stg_exit(exit_code);
         }
     }
 
     return action;
 }
 
+long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data)
+{
+    filter_called = true;
+    long result = EXCEPTION_CONTINUE_EXECUTION;
+    if (oldTopFilter)
+    {
+        result = (*oldTopFilter)(exception_data);
+        if (EXCEPTION_CONTINUE_SEARCH == result)
+            result = EXCEPTION_CONTINUE_EXECUTION;
+        return result;
+    }
+
+    crash_dump = true;
+    return result;
+}
+
 void __register_hs_exception_handler( void )
 {
-    // Allow the VEH handler to be registered only once.
+    if (!RtsFlags.MiscFlags.install_seh_handlers)
+        return;
+
+    // Allow the VCH handler to be registered only once.
     if (NULL == __hs_handle)
     {
-        __hs_handle = AddVectoredExceptionHandler(CALL_FIRST, __hs_exception_handler);
+        // Be the last one to run, We can then be sure we didn't interfere with
+        // anything else.
+        __hs_handle = AddVectoredContinueHandler(CALL_LAST,
+                                                 __hs_exception_handler);
         // should the handler not be registered this will return a null.
         assert(__hs_handle);
+
+        // Register for an exception filter to ensure the continue handler gets
+        // hit if no one handled the exception.
+        oldTopFilter = SetUnhandledExceptionFilter (__hs_exception_filter);
     }
     else
     {
-        errorBelch("There is no need to call __register_hs_exception_handler() twice, VEH handlers are global per process.");
+        errorBelch("There is no need to call __register_hs_exception_handler()"
+                   " twice, VEH handlers are global per process.");
     }
 }
 
 void __unregister_hs_exception_handler( void )
 {
+    if (!RtsFlags.MiscFlags.install_seh_handlers)
+        return;
+
     if (__hs_handle != NULL)
     {
         // Should the return value be checked? we're terminating anyway.
-        RemoveVectoredExceptionHandler(__hs_handle);
+        RemoveVectoredContinueHandler(__hs_handle);
         __hs_handle = NULL;
     }
     else
     {
-        errorBelch("__unregister_hs_exception_handler() called without having called __register_hs_exception_handler() first.");
+        errorBelch("__unregister_hs_exception_handler() called without having"
+                   "called __register_hs_exception_handler() first.");
     }
 }
 
+// Generate a crash dump, however in order for these to generate undecorated
+// names we really need to be able to generate PDB files.
+void generateDump (EXCEPTION_POINTERS* pExceptionPointers)
+{
+    if (!RtsFlags.MiscFlags.generate_dump_file)
+        return;
+
+    WCHAR szPath[MAX_PATH];
+    WCHAR szFileName[MAX_PATH];
+    WCHAR const *const szAppName = L"ghc";
+    WCHAR const *const szVersion = L"";
+    DWORD dwBufferSize = MAX_PATH;
+    HANDLE hDumpFile;
+    SYSTEMTIME stLocalTime;
+    MINIDUMP_EXCEPTION_INFORMATION ExpParam;
+
+    GetLocalTime (&stLocalTime);
+    GetTempPathW (dwBufferSize, szPath);
+
+    swprintf (szFileName, MAX_PATH,
+              L"%ls%ls%ls-%04d%02d%02d-%02d%02d%02d-%ld-%ld.dmp",
+              szPath, szAppName, szVersion,
+              stLocalTime.wYear, stLocalTime.wMonth, stLocalTime.wDay,
+              stLocalTime.wHour, stLocalTime.wMinute, stLocalTime.wSecond,
+              GetCurrentProcessId(), GetCurrentThreadId());
+    hDumpFile = CreateFileW (szFileName, GENERIC_READ|GENERIC_WRITE,
+                FILE_SHARE_WRITE|FILE_SHARE_READ, 0, CREATE_ALWAYS, 0, 0);
+
+    ExpParam.ThreadId          = GetCurrentThreadId();
+    ExpParam.ExceptionPointers = pExceptionPointers;
+    ExpParam.ClientPointers    = TRUE;
+
+    MiniDumpWriteDump(GetCurrentProcess(), GetCurrentProcessId(),
+                      hDumpFile, MiniDumpNormal | MiniDumpWithDataSegs |
+                                 MiniDumpWithThreadInfo | MiniDumpWithCodeSegs,
+                      &ExpParam, NULL, NULL);
+
+    fprintf (stderr, "Crash dump created. Dump written to:\n\t%ls", szFileName);
+}
+
+// Generate stack trace information, we can piggy back on information we know
+// about in the runtime linker to resolve symbols. So this is a good opportunity
+// to make the output more useful.
+void generateStack (EXCEPTION_POINTERS* pExceptionPointers)
+{
+    if (!RtsFlags.MiscFlags.generate_stack_trace)
+        return;
+
+    PCONTEXT context = pExceptionPointers->ContextRecord;
+    STACKFRAME64 stackFrame = {0};
+    DWORD machineType;
+
+#if defined(x86_64_HOST_ARCH)
+    machineType = IMAGE_FILE_MACHINE_AMD64;
+    stackFrame.AddrPC.Offset = context->Rip;
+    stackFrame.AddrPC.Mode = AddrModeFlat;
+
+    stackFrame.AddrFrame.Offset = context->Rbp;
+    stackFrame.AddrFrame.Mode = AddrModeFlat;
+
+    stackFrame.AddrStack.Offset = context->Rsp;
+    stackFrame.AddrStack.Mode = AddrModeFlat;
+#else
+    machineType = IMAGE_FILE_MACHINE_I386;
+    stackFrame.AddrPC.Offset = context->Eip;
+    stackFrame.AddrPC.Mode = AddrModeFlat;
+
+    stackFrame.AddrFrame.Offset = context->Ebp;
+    stackFrame.AddrFrame.Mode = AddrModeFlat;
+
+    stackFrame.AddrStack.Offset = context->Esp;
+    stackFrame.AddrStack.Mode = AddrModeFlat;
+#endif
+    fprintf (stderr, "\n Attempting to reconstruct a stack trace...\n\n");
+    if (!SymInitialize (GetCurrentProcess (), NULL, true))
+        fprintf (stderr, "  \nNOTE: Symbols could not be loaded. Addresses may"
+                         " be unresolved.\n\n");
+
+    /* Maximum amount of stack frames to show.  */
+    /* Phyx: I'm not sure if I should make this configurable or not. Would a
+       longer stack really be more useful? usually you only care about the top
+       few.  */
+    int max_frames = 35;
+
+    fprintf (stderr, "   Frame\tCode address\n");
+    DWORD64 lastBp = 0; /* Prevent loops with optimized stackframes.  */
+    while (StackWalk64 (machineType, GetCurrentProcess(), GetCurrentThread(),
+                        &stackFrame, context, NULL, SymFunctionTableAccess64,
+                        SymGetModuleBase64, NULL) && max_frames > 0)
+    {
+        if (stackFrame.AddrPC.Offset == 0)
+        {
+            fprintf (stderr, "Null address\n");
+            break;
+        }
+        wchar_t buffer[1024];
+        uintptr_t topSp = 0;
+        fprintf (stderr, " * 0x%" PRIxPTR "\t%ls\n",
+                 (uintptr_t)stackFrame.AddrFrame.Offset,
+                 resolveSymbolAddr ((wchar_t*)&buffer, 1024,
+                                   (SymbolAddr*)(intptr_t)stackFrame.AddrPC.Offset,
+                                   &topSp));
+        if (lastBp >= stackFrame.AddrFrame.Offset)
+        {
+            fprintf (stderr, "Stack frame out of sequence...\n");
+            break;
+        }
+        lastBp = stackFrame.AddrFrame.Offset;
+
+        max_frames--;
+        if (max_frames ==0)
+        {
+            fprintf (stderr, "\n   ... (maximum recursion depth reached.)\n");
+        }
+    }
+    fprintf (stderr, "\n");
+    fflush(stderr);
+}
diff --git a/rts/win32/veh_excn.h b/rts/win32/veh_excn.h
index fda837f1f1..e0a11ade58 100644
--- a/rts/win32/veh_excn.h
+++ b/rts/win32/veh_excn.h
@@ -63,7 +63,12 @@
 // See https://msdn.microsoft.com/en-us/library/windows/desktop/ms681419(v=vs.85).aspx
 //
 long WINAPI __hs_exception_handler( struct _EXCEPTION_POINTERS *exception_data );
+long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data);
 
 // prototypes to the functions doing the registration and unregistration of the VEH handlers
 void __register_hs_exception_handler( void );
 void __unregister_hs_exception_handler( void );
+
+// prototypes for dump methods.
+void generateDump(EXCEPTION_POINTERS* pExceptionPointers);
+void generateStack (EXCEPTION_POINTERS* pExceptionPointers);