Add stack traces on crashes on Windows

Summary:
This patch adds the ability to generate stack traces on crashes for Windows.
When running in the interpreter this attempts to use symbol information from
the interpreter and information we know about the loaded object files to
resolve addresses to symbols.

When running compiled it doesn't have this information and then defaults
to using symbol information from PDB files. Which for now means only
files compiled with ICC or MSVC will show traces compiled.

But I have a future patch that may address this shortcoming.

Also since I don't know how to walk a pure haskell stack, I can for now
only show the last entry. I'm hoping to figure out how Apply.cmm works to
be able to walk the stalk and give more entries for pure haskell code.

In GHCi

```
$ echo main | inplace/bin/ghc-stage2.exe --interactive ./testsuite/tests/rts/derefnull.hs
GHCi, version 8.3.20170830: http://www.haskell.org/ghc/  :? for help
Ok, 1 module loaded.
Prelude Main>
Access violation in generated code when reading 0x0

 Attempting to reconstruct a stack trace...

   Frame        Code address
 * 0x77cde10    0xc370229 E:\..\base\dist-install\build\HSbase-4.10.0.0.o+0x190031
                 (base_ForeignziStorable_zdfStorableInt4_info+0x3f)
```

and compiled

```
Access violation in generated code when reading 0x0

 Attempting to reconstruct a stack trace...

   Frame        Code address
 * 0xf0dbd0     0x40bb01 E:\..\rts\derefnull.run\derefnull.exe+0xbb01
```

Test Plan: ./validate

Reviewers: austin, hvr, bgamari, erikd, simonmar

Reviewed By: bgamari

Subscribers: rwbarton, thomie

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

8 files changed, 325 insertions, 4 deletions

diff --git a/rts/Linker.c b/rts/Linker.c
index 30d7e87f92..8f55c296a6 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -980,6 +980,21 @@ void ghci_enquire(SymbolAddr* addr)
 }
 #endif
 
+pathchar*
+resolveSymbolAddr (pathchar* buffer, int size,
+                   SymbolAddr* symbol, uintptr_t* top)
+{
+#if defined(OBJFORMAT_PEi386)
+  return resolveSymbolAddr_PEi386 (buffer, size, symbol, top);
+#else /* OBJFORMAT_PEi386 */
+  (void)buffer;
+  (void)size;
+  (void)symbol;
+  (void)top;
+  return NULL;
+#endif /* OBJFORMAT_PEi386 */
+}
+
 #if RTS_LINKER_USE_MMAP
 //
 // Returns NULL on failure.
diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
index dd17be0992..21602f15aa 100644
--- a/rts/LinkerInternals.h
+++ b/rts/LinkerInternals.h
@@ -264,6 +264,9 @@ SymbolAddr* lookupSymbol_ (SymbolName* lbl);
 
 extern /*Str*/HashTable *symhash;
 
+pathchar*
+resolveSymbolAddr (pathchar* buffer, int size,
+                   SymbolAddr* symbol, uintptr_t* top);
 
 /*************************************************
  * Various bits of configuration
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 5bdf9922de..c0571368cd 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_stack_trace    = true;
     RtsFlags.MiscFlags.generate_dump_file      = false;
     RtsFlags.MiscFlags.machineReadable         = false;
     RtsFlags.MiscFlags.linkerMemBase           = 0;
@@ -435,6 +436,10 @@ usage_text[] = {
 "            Generate Windows crash dumps, requires exception handlers",
 "            to be installed. Implies --install-signal-handlers=yes.",
 "            (default: no)",
+"  --generate-stack-traces=<yes|no>",
+"            Generate a stack trace when your application encounters a",
+"            fatal error. When symbols are available an attempt will be",
+"            made to resolve addresses to names. (default: yes)",
 #endif
 #if defined(THREADED_RTS)
 "  -e<n>     Maximum number of outstanding local sparks (default: 4096)",
@@ -860,6 +865,16 @@ error = true;
                       OPTION_UNSAFE;
                       RtsFlags.MiscFlags.install_seh_handlers = false;
                   }
+                  else if (strequal("generate-stack-traces=yes",
+                               &rts_argv[arg][2])) {
+                      OPTION_UNSAFE;
+                      RtsFlags.MiscFlags.generate_stack_trace = true;
+                  }
+                  else if (strequal("generate-stack-traces=no",
+                              &rts_argv[arg][2])) {
+                      OPTION_UNSAFE;
+                      RtsFlags.MiscFlags.generate_stack_trace = false;
+                  }
                   else if (strequal("generate-crash-dumps",
                               &rts_argv[arg][2])) {
                       OPTION_UNSAFE;
diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c
index 4378a0a61d..3dcf8c4281 100644
--- a/rts/linker/PEi386.c
+++ b/rts/linker/PEi386.c
@@ -153,6 +153,10 @@
 static uint8_t* cstring_from_COFF_symbol_name(
     uint8_t* name,
     uint8_t* strtab);
+#include <inttypes.h>
+#include <dbghelp.h>
+#include <stdlib.h>
+#include <Psapi.h>
 
 #if defined(x86_64_HOST_ARCH)
 static size_t makeSymbolExtra_PEi386(
@@ -2059,4 +2063,196 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl)
     }
 }
 
+/* -----------------------------------------------------------------------------
+ * Debugging operations.
+ */
+
+pathchar*
+resolveSymbolAddr_PEi386 (pathchar* buffer, int size,
+                          SymbolAddr* symbol, uintptr_t* top ){
+    SYMBOL_INFO sym;
+    ZeroMemory (&sym, sizeof(SYMBOL_INFO));
+    sym.MaxNameLen = sizeof(char) * 1024;
+
+    DWORD64 uDisplacement = 0;
+    HANDLE hProcess = GetCurrentProcess();
+    ObjectCode* obj = NULL;
+    uintptr_t start, end;
+    *top = 0;
+
+    pathprintf (buffer, size, WSTR("0x%" PRIxPTR), symbol);
+
+    if (SymFromAddr (hProcess, (uintptr_t)symbol, &uDisplacement, &sym))
+    {
+      /* Try using Windows symbols.  */
+      wcscat (buffer, WSTR(" "));
+      pathchar* name = mkPath (sym.Name);
+      wcscat (buffer, name);
+      stgFree (name);
+      if (uDisplacement != 0)
+      {
+        int64_t displacement = (int64_t)uDisplacement;
+        pathchar s_disp[50];
+        if (displacement < 0)
+          pathprintf ((pathchar*)s_disp, 50, WSTR("-%ld"), -displacement);
+        else
+          pathprintf ((pathchar*)s_disp, 50, WSTR("+%ld"), displacement);
+
+        wcscat (buffer, s_disp);
+      }
+    }
+    else
+    {
+      /* Try to calculate from information inside the rts.  */
+      uintptr_t loc = (uintptr_t)symbol;
+      for (ObjectCode* oc = objects; oc; oc = oc->next) {
+          for (int i = 0; i < oc->n_sections; i++) {
+              Section section = oc->sections[i];
+              start = (uintptr_t)section.start;
+              end   = start + section.size;
+              if (loc > start && loc <= end)
+              {
+                  wcscat (buffer, WSTR(" "));
+                  if (oc->archiveMemberName)
+                  {
+                      pathchar* name = mkPath (oc->archiveMemberName);
+                      wcscat (buffer, name);
+                      stgFree (name);
+                  }
+                  else
+                  {
+                      wcscat (buffer, oc->fileName);
+                  }
+                  pathchar s_disp[50];
+                  pathprintf (s_disp, 50, WSTR("+0x%" PRIxPTR), loc - start);
+                  wcscat (buffer, s_disp);
+                  obj = oc;
+                  goto exit_loop;
+              }
+          }
+      }
+
+      /* If we managed to make it here, we must not have any symbols nor be
+         dealing with code we've linked. The only thing left is an internal
+         segfault or one in a dynamic library. So let's enumerate the module
+         address space.  */
+      HMODULE *hMods = NULL;
+      DWORD cbNeeded;
+      EnumProcessModules (hProcess, hMods, 0, &cbNeeded);
+      hMods = stgMallocBytes (cbNeeded, "resolveSymbolAddr_PEi386");
+      if (EnumProcessModules (hProcess, hMods, cbNeeded, &cbNeeded))
+      {
+        uintptr_t loc = (uintptr_t)symbol;
+        MODULEINFO info;
+        for (uint32_t i = 0; i < cbNeeded / sizeof(HMODULE); i++) {
+           ZeroMemory (&info, sizeof (MODULEINFO));
+           if (GetModuleInformation (hProcess, hMods[i], &info,
+                                     sizeof(MODULEINFO)))
+           {
+             uintptr_t start = (uintptr_t)info.lpBaseOfDll;
+             uintptr_t end   = start + info.SizeOfImage;
+             if (loc >= start && loc < end)
+             {
+                /* Hoera, finally found some information.  */
+                pathchar tmp[MAX_PATH];
+                if (GetModuleFileNameExW (hProcess, hMods[i], tmp, MAX_PATH))
+                {
+                  wcscat (buffer, WSTR(" "));
+                  wcscat (buffer, tmp);
+                  pathprintf (tmp, MAX_PATH, WSTR("+0x%" PRIxPTR), loc - start);
+                  wcscat (buffer, tmp);
+                }
+                break;
+             }
+           }
+        }
+      }
+
+      stgFree(hMods);
+    }
+
+    /* Finally any file/line number.  */
+    IMAGEHLP_LINE64 lineInfo = {0};
+    DWORD dwDisplacement = 0;
+  exit_loop:
+    if (SymGetLineFromAddr64(hProcess, (uintptr_t)symbol, &dwDisplacement,
+                             &lineInfo))
+    {
+      /* Try using Windows symbols.  */
+      pathchar s_line[512];
+      pathprintf ((pathchar*) s_line, 512, WSTR("   %ls (%lu)"),
+                  lineInfo.FileName, lineInfo.LineNumber);
+      wcscat (buffer, s_line);
+      if (dwDisplacement != 0)
+      {
+        pathprintf ((pathchar*) s_line, 512, WSTR(" +%lu byte%s"),
+                    dwDisplacement,
+                    (dwDisplacement == 1 ? WSTR("") : WSTR("s")));
+      }
+      wcscat (buffer, s_line);
+    }
+    else if (obj)
+    {
+      /* Try to calculate from information inside the rts.  */
+      typedef struct _SymX { SymbolName* name; uintptr_t loc; } SymX;
+      SymX* locs = stgCallocBytes (sizeof(SymX), obj->n_symbols,
+                                   "resolveSymbolAddr");
+      int blanks = 0;
+      for (int i = 0; i < obj->n_symbols; i++) {
+          SymbolName* sym = obj->symbols[i];
+          if (sym == NULL)
+            {
+               blanks++;
+               continue;
+            }
+          RtsSymbolInfo* a = NULL;
+          ghciLookupSymbolInfo(symhash, sym, &a);
+          if (a) {
+              SymX sx = {0};
+              sx.name = sym;
+              sx.loc  = (uintptr_t)a->value;
+              locs[i] = sx;
+          }
+      }
+      int comp (const void * elem1, const void * elem2)
+      {
+          SymX f = *((SymX*)elem1);
+          SymX s = *((SymX*)elem2);
+          if (f.loc > s.loc) return  1;
+          if (f.loc < s.loc) return -1;
+          return 0;
+      }
+      qsort (locs, obj->n_symbols, sizeof (SymX), comp);
+      uintptr_t key  = (uintptr_t)symbol;
+      SymX* res = NULL;
+
+      for (int x = blanks; x < obj->n_symbols; x++) {
+          if (x < (obj->n_symbols -1)) {
+              if (locs[x].loc >= key && key < locs[x+1].loc) {
+                res = &locs[x];
+                break;
+              }
+          }
+          else
+          {
+              if (locs[x].loc >= key) {
+                  res = &locs[x];
+                  break;
+                }
+          }
+      }
+
+      if (res) {
+          pathchar s_disp[512];
+          *top = (uintptr_t)res->loc;
+          pathprintf ((pathchar*)s_disp, 512,
+                      WSTR("\n\t\t (%s+0x%" PRIxPTR ")"),
+                      res->name, res->loc - key);
+          wcscat (buffer, s_disp);
+      }
+      stgFree (locs);
+    }
+
+    return buffer;
+}
 #endif /* mingw32_HOST_OS */
diff --git a/rts/linker/PEi386.h b/rts/linker/PEi386.h
index e84e05232a..e6fef74af8 100644
--- a/rts/linker/PEi386.h
+++ b/rts/linker/PEi386.h
@@ -57,6 +57,8 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl);
 bool ocAllocateSymbolExtras_PEi386 ( ObjectCode* oc );
 SymbolAddr *lookupSymbolInDLLs ( unsigned char *lbl );
 /* See Note [mingw-w64 name decoration scheme] */
+pathchar* resolveSymbolAddr_PEi386 ( pathchar* buffer, int size,
+                                     SymbolAddr* symbol, uintptr_t* top );
 
 char *
 allocateImageAndTrampolines (
diff --git a/rts/package.conf.in b/rts/package.conf.in
index 4eb75fc704..52d7ef8be2 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -46,6 +46,7 @@ extra-libraries:
                               ,"gdi32"      /* for the linker */
                               ,"winmm"      /* for the linker */
                               ,"Dbghelp"    /* for crash dump */
+                              ,"Psapi"      /* for process information.  */
 #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 5105d7676f..3ac008d780 100644
--- a/rts/win32/veh_excn.c
+++ b/rts/win32/veh_excn.c
@@ -9,8 +9,12 @@
 #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>
@@ -117,9 +121,14 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
             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]
+                                " 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;
                 break;
@@ -132,6 +141,7 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
         if (EXCEPTION_CONTINUE_EXECUTION == action)
         {
             fflush(stdout);
+            generateStack (exception_data);
             generateDump (exception_data);
             stg_exit(EXIT_FAILURE);
         }
@@ -153,7 +163,6 @@ long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data)
     }
 
     crash_dump = true;
-
     return result;
 }
 
@@ -240,3 +249,82 @@ void generateDump (EXCEPTION_POINTERS* pExceptionPointers)
 
     fprintf (stdout, "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 (stdout, "\n Attempting to reconstruct a stack trace...\n\n");
+    if (!SymInitialize (GetCurrentProcess (), NULL, true))
+        fprintf (stdout, "  \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 (stdout, "   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 (stdout, "Null address\n");
+            break;
+        }
+        wchar_t buffer[1024];
+        uintptr_t topSp = 0;
+        fprintf (stdout, " * 0x%" PRIxPTR "\t%ls\n",
+                 (uintptr_t)stackFrame.AddrFrame.Offset,
+                 resolveSymbolAddr ((wchar_t*)&buffer, 1024,
+                                   (SymbolAddr*)stackFrame.AddrPC.Offset,
+                                   &topSp));
+        if (lastBp >= stackFrame.AddrFrame.Offset)
+        {
+            fprintf (stdout, "Stack frame out of sequence...\n");
+            break;
+        }
+        lastBp = stackFrame.AddrFrame.Offset;
+
+        max_frames--;
+        if (max_frames ==0)
+        {
+            fprintf (stdout, "\n   ... (maximum recursion depth reached.)\n");
+        }
+    }
+    fprintf (stdout, "\n");
+    fflush(stdout);
+}
diff --git a/rts/win32/veh_excn.h b/rts/win32/veh_excn.h
index 4a2134861c..e0a11ade58 100644
--- a/rts/win32/veh_excn.h
+++ b/rts/win32/veh_excn.h
@@ -71,3 +71,4 @@ void __unregister_hs_exception_handler( void );
 
 // prototypes for dump methods.
 void generateDump(EXCEPTION_POINTERS* pExceptionPointers);
+void generateStack (EXCEPTION_POINTERS* pExceptionPointers);