Add ability to produce crash dumps on Windows

It's often hard to debug things like segfaults on Windows,
mostly because gdb isn't always of use and users don't know
how to effectively use it.

This patch provides a way to create a crash drump by passing

`+RTS --generate-crash-dumps` as an option. If any unhandled
exception is triggered a dump is made that contains enough
information to be able to diagnose things successfully.

Currently the created dumps are a bit big because I include
all registers, code and threads information.

This looks like

```
$ testsuite/tests/rts/derefnull.run/derefnull.exe +RTS
--generate-crash-dumps

Access violation in generated code when reading 0000000000000000
Crash dump created. Dump written to:
        E:\msys64\tmp\ghc-20170901-220250-11216-16628.dmp
```

Test Plan: ./validate

Reviewers: austin, hvr, bgamari, erikd, simonmar

Reviewed By: bgamari, simonmar

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3912

9 files changed, 92 insertions, 1 deletions

diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst
index 107519d92a..142f9f9340 100644
--- a/docs/users_guide/8.4.1-notes.rst
+++ b/docs/users_guide/8.4.1-notes.rst
@@ -170,6 +170,9 @@ Runtime system
   completely disable the runtime's handling of exceptions. See
   :ghc-ticket:`13911`, :ghc-ticket:`12110`.
 
+- The GHC runtime on Windows can now generate crash dumps on unhandled exceptions
+  using the RTS flag :rts-flag:`--generate-crash-dumps`.
+
 Template Haskell
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index 7afc7262f8..905048c69b 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -228,6 +228,13 @@ Miscellaneous RTS options
     DLL, and don't want the RTS to ungracefully terminate your application on
     erros such as segfaults.
 
+.. rts-flag:: --generate-crash-dumps
+
+    If yes (the default), the RTS on Windows will generate a core dump on
+    any crash. These dumps can be inspected using debuggers such as WinDBG.
+    The dumps record all code, registers and threading information at the time
+    of the crash. Note that this implies `--install-seh-handlers=yes`.
+
 .. rts-flag:: -xm ⟨address⟩
 
     .. index::
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index e67f176560..4cc267072d 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -190,6 +190,7 @@ typedef struct _MISC_FLAGS {
     Time    tickInterval;        /* units: TIME_RESOLUTION */
     bool install_signal_handlers;
     bool install_seh_handlers;
+    bool generate_dump_file;
     bool machineReadable;
     StgWord linkerMemBase;       /* address to ask the OS for memory
                                   * for the linker, NULL ==> off */
diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc
index df7cebf9b8..62b79ed064 100644
--- a/libraries/base/GHC/RTS/Flags.hsc
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -132,6 +132,7 @@ data MiscFlags = MiscFlags
     { tickInterval          :: RtsTime
     , installSignalHandlers :: Bool
     , installSEHHandlers    :: Bool
+    , generateCrashDumpFile :: Bool
     , machineReadable       :: Bool
     , linkerMemBase         :: Word
       -- ^ address to ask the OS for memory for the linker, 0 ==> off
@@ -406,6 +407,7 @@ getMiscFlags = do
   MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
             <*> #{peek MISC_FLAGS, install_signal_handlers} ptr
             <*> #{peek MISC_FLAGS, install_seh_handlers} ptr
+            <*> #{peek MISC_FLAGS, generate_dump_file} ptr
             <*> #{peek MISC_FLAGS, machineReadable} ptr
             <*> #{peek MISC_FLAGS, linkerMemBase} ptr
 
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 2ce4fd36c7..ed8ab13580 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -53,6 +53,9 @@
   * Add `installSEHHandlers` to `MiscFlags` in `GHC.RTS.Flags` to determine if
     exception handling is enabled.
 
+  * Add `generateCrashDumpFile` to `MiscFlags` in `GHC.RTS.Flags` to determine
+    if a core dump will be generated on crashes.
+
 ## 4.10.0.0 *July 2017*
   * Bundled with GHC 8.2.1
 
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 5a5abb0d19..5bdf9922de 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -226,6 +226,7 @@ void initRtsFlagsDefaults(void)
 
     RtsFlags.MiscFlags.install_signal_handlers = true;
     RtsFlags.MiscFlags.install_seh_handlers    = true;
+    RtsFlags.MiscFlags.generate_dump_file      = false;
     RtsFlags.MiscFlags.machineReadable         = false;
     RtsFlags.MiscFlags.linkerMemBase           = 0;
 
@@ -430,6 +431,10 @@ usage_text[] = {
 #if defined(mingw32_HOST_OS)
 "  --install-seh-handlers=<yes|no>",
 "            Install exception handlers (default: yes)",
+"  --generate-crash-dumps",
+"            Generate Windows crash dumps, requires exception handlers",
+"            to be installed. Implies --install-signal-handlers=yes.",
+"            (default: no)",
 #endif
 #if defined(THREADED_RTS)
 "  -e<n>     Maximum number of outstanding local sparks (default: 4096)",
@@ -855,6 +860,11 @@ error = true;
                       OPTION_UNSAFE;
                       RtsFlags.MiscFlags.install_seh_handlers = false;
                   }
+                  else if (strequal("generate-crash-dumps",
+                              &rts_argv[arg][2])) {
+                      OPTION_UNSAFE;
+                      RtsFlags.MiscFlags.generate_dump_file = true;
+                  }
                   else if (strequal("machine-readable",
                                &rts_argv[arg][2])) {
                       OPTION_UNSAFE;
@@ -1608,6 +1618,11 @@ static void normaliseRtsOpts (void)
             RtsFlags.ParFlags.parGcLoadBalancingGen = 1;
         }
     }
+
+    // We can't generate dumps without signal handlers
+    if (RtsFlags.MiscFlags.generate_dump_file) {
+        RtsFlags.MiscFlags.install_seh_handlers = true;
+    }
 }
 
 static void errorUsage (void)
diff --git a/rts/package.conf.in b/rts/package.conf.in
index 2f722f10e7..4eb75fc704 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -45,6 +45,7 @@ extra-libraries:
                               ,"wsock32"    /* for the linker */
                               ,"gdi32"      /* for the linker */
                               ,"winmm"      /* for the linker */
+                              ,"Dbghelp"    /* for crash dump */
 #endif
 #if NEED_PTHREAD_LIB
                               , "pthread"   /* for pthread_getthreadid_np, pthread_create, etc. */
diff --git a/rts/win32/veh_excn.c b/rts/win32/veh_excn.c
index e45ea2b49c..5105d7676f 100644
--- a/rts/win32/veh_excn.c
+++ b/rts/win32/veh_excn.c
@@ -5,11 +5,18 @@
 * Error Handling implementations for windows
 *
 * ---------------------------------------------------------------------------*/
-
+#define UNICODE 1
 #include "Rts.h"
 #include "ghcconfig.h"
 #include "veh_excn.h"
 #include <assert.h>
+#include <stdbool.h>
+#include <wchar.h>
+#include <windows.h>
+#include <stdio.h>
+#include <excpt.h>
+#include <inttypes.h>
+#include <Dbghelp.h>
 
 /////////////////////////////////
 // Exception / signal handlers.
@@ -80,11 +87,17 @@
 // 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)
 {
+    if (!crash_dump && filter_called)
+      return EXCEPTION_CONTINUE_EXECUTION;
+
     long action = EXCEPTION_CONTINUE_SEARCH;
     ULONG_PTR what;
+    fprintf (stdout, "\n");
 
     // When the system unwinds the VEH stack after having handled an excn,
     // return immediately.
@@ -119,6 +132,7 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
         if (EXCEPTION_CONTINUE_EXECUTION == action)
         {
             fflush(stdout);
+            generateDump (exception_data);
             stg_exit(EXIT_FAILURE);
         }
     }
@@ -128,6 +142,7 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
 
 long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data)
 {
+    filter_called = true;
     long result = EXCEPTION_CONTINUE_EXECUTION;
     if (oldTopFilter)
     {
@@ -137,6 +152,8 @@ long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data)
         return result;
     }
 
+    crash_dump = true;
+
     return result;
 }
 
@@ -184,3 +201,42 @@ void __unregister_hs_exception_handler( void )
     }
 }
 
+// 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 (stdout, "Crash dump created. Dump written to:\n\t%ls", szFileName);
+}
diff --git a/rts/win32/veh_excn.h b/rts/win32/veh_excn.h
index 72a9967afd..4a2134861c 100644
--- a/rts/win32/veh_excn.h
+++ b/rts/win32/veh_excn.h
@@ -68,3 +68,6 @@ 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);