Switch VEH to VCH and allow disabling of SEH completely.

Exception handling on Windows is unfortunately a bit complicated.
But essentially the VEH Handlers we currently have are running too
early.

This was a problem as it ran so early it also swallowed C++ exceptions
and other software exceptions which the system could have very well
recovered from.

So instead we use a sequence of chains to for the exception handlers to
run as late as possible. You really can't get any later than this.

Please read the comment in the patch for more details.

I'm also providing a switch to allow people to turn off the exception
handling entirely. In case it does present a problem with their code.

Test Plan: ./validate

Reviewers: austin, hvr, bgamari, erikd, simonmar

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #13911, #12110

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

9 files changed, 133 insertions, 18 deletions

diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst
index 4f3ff263cb..f525a8197a 100644
--- a/docs/users_guide/8.4.1-notes.rst
+++ b/docs/users_guide/8.4.1-notes.rst
@@ -163,6 +163,13 @@ Runtime system
   compliance with the model set by the most Java virtual machine
   implementations.
 
+- The GHC runtime on Windows now uses Continue handlers instead of Vectorized
+  handlers to trap exceptions. This change gives other exception handlers a chance
+  to handle the exception before the runtime does. Furthermore The RTS flag
+  :rts-flag:`--install-seh-handlers=<yes|no>` Can be used on Wndows to
+  completely disable the runtime's handling of exceptions. See
+  :ghc-ticket:`13911`, :ghc-ticket:`12110`.
+
 Template Haskell
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index f141c323f6..7afc7262f8 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -220,6 +220,14 @@ Miscellaneous RTS options
     capabilities. To disable the timer signal, use the ``-V0`` RTS
     option (see above).
 
+.. rts-flag:: --install-seh-handlers=⟨yes|no⟩
+
+    If yes (the default), the RTS on Windows installs exception handlers to
+    catch unhandled exceptions using the Windows exception handling mechanism.
+    This option is primarily useful for when you are using the Haskell code as a
+    DLL, and don't want the RTS to ungracefully terminate your application on
+    erros such as segfaults.
+
 .. rts-flag:: -xm ⟨address⟩
 
     .. index::
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index 6040201c73..e67f176560 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -189,6 +189,7 @@ typedef struct _CONCURRENT_FLAGS {
 typedef struct _MISC_FLAGS {
     Time    tickInterval;        /* units: TIME_RESOLUTION */
     bool install_signal_handlers;
+    bool install_seh_handlers;
     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 7bb10b60cb..df7cebf9b8 100644
--- a/libraries/base/GHC/RTS/Flags.hsc
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -131,6 +131,7 @@ data ConcFlags = ConcFlags
 data MiscFlags = MiscFlags
     { tickInterval          :: RtsTime
     , installSignalHandlers :: Bool
+    , installSEHHandlers    :: Bool
     , machineReadable       :: Bool
     , linkerMemBase         :: Word
       -- ^ address to ask the OS for memory for the linker, 0 ==> off
@@ -404,6 +405,7 @@ getMiscFlags = do
   let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr
   MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
             <*> #{peek MISC_FLAGS, install_signal_handlers} ptr
+            <*> #{peek MISC_FLAGS, install_seh_handlers} ptr
             <*> #{peek MISC_FLAGS, machineReadable} ptr
             <*> #{peek MISC_FLAGS, linkerMemBase} ptr
 
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 5b1e147cb5..4671c716d9 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -50,6 +50,9 @@
   * `Type.Reflection.withTypeable` is now polymorphic in the `RuntimeRep` of
     its result.
 
+  * Add `installSEHHandlers` to `MiscFlags` in `GHC.RTS.Flags` to determine if
+    exception handling is enabled.
+
 ## 4.10.0.0 *April 2017*
   * Bundled with GHC *TBA*
 
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 4194aa0eec..5a5abb0d19 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -225,8 +225,9 @@ void initRtsFlagsDefaults(void)
     RtsFlags.ConcFlags.ctxtSwitchTime   = USToTime(20000); // 20ms
 
     RtsFlags.MiscFlags.install_signal_handlers = true;
-    RtsFlags.MiscFlags.machineReadable = false;
-    RtsFlags.MiscFlags.linkerMemBase    = 0;
+    RtsFlags.MiscFlags.install_seh_handlers    = true;
+    RtsFlags.MiscFlags.machineReadable         = false;
+    RtsFlags.MiscFlags.linkerMemBase           = 0;
 
 #if defined(THREADED_RTS)
     RtsFlags.ParFlags.nCapabilities     = 1;
@@ -426,6 +427,10 @@ usage_text[] = {
 #endif
 "  --install-signal-handlers=<yes|no>",
 "            Install signal handlers (default: yes)",
+#if defined(mingw32_HOST_OS)
+"  --install-seh-handlers=<yes|no>",
+"            Install exception handlers (default: yes)",
+#endif
 #if defined(THREADED_RTS)
 "  -e<n>     Maximum number of outstanding local sparks (default: 4096)",
 #endif
@@ -840,6 +845,16 @@ error = true;
                       OPTION_UNSAFE;
                       RtsFlags.MiscFlags.install_signal_handlers = false;
                   }
+                  else if (strequal("install-seh-handlers=yes",
+                              &rts_argv[arg][2])) {
+                      OPTION_UNSAFE;
+                      RtsFlags.MiscFlags.install_seh_handlers = true;
+                  }
+                  else if (strequal("install-seh-handlers=no",
+                              &rts_argv[arg][2])) {
+                      OPTION_UNSAFE;
+                      RtsFlags.MiscFlags.install_seh_handlers = false;
+                  }
                   else if (strequal("machine-readable",
                                &rts_argv[arg][2])) {
                       OPTION_UNSAFE;
diff --git a/rts/RtsMain.c b/rts/RtsMain.c
index 57c38742b6..21b8577cca 100644
--- a/rts/RtsMain.c
+++ b/rts/RtsMain.c
@@ -24,28 +24,26 @@
 
 // Hack: we assume that we're building a batch-mode system unless
 // INTERPRETER is set
- 
+
 #if !defined(INTERPRETER) /* Hack */
 
 // The rts entry point from a compiled program using a Haskell main
 // function.  This gets called from a tiny main function generated by
 // GHC and linked into each compiled Haskell program that uses a
 // Haskell main function.
-// 
+//
 // We expect the caller to pass ZCMain_main_closure for
 // main_closure. The reason we cannot refer to this symbol directly
 // is because we're inside the rts and we do not know for sure that
 // we'll be using a Haskell main function.
-// 
+//
 // NOTE: This function is marked as _noreturn_ in Main.h
 
 int hs_main ( int argc, char *argv[],       // program args
               StgClosure *main_closure,     // closure for Main.main
               RtsConfig rts_config)         // RTS configuration
-              
-{
-    BEGIN_WINDOWS_VEH_HANDLER
 
+{
     int exit_status;
     SchedulerStatus status;
 
@@ -56,15 +54,14 @@ int hs_main ( int argc, char *argv[],       // program args
     }
     #endif
 
-
-
-
     hs_init_ghc(&argc, &argv, rts_config);
 
+    BEGIN_WINDOWS_VEH_HANDLER
+
     // kick off the computation by creating the main thread with a pointer
     // to mainIO_closure representing the computation of the overall program;
     // then enter the scheduler with this thread and off we go;
-    // 
+    //
     // in a parallel setup, where we have many instances of this code
     // running on different PEs, we should do this only for the main PE
     // (IAmMainThread is set in startupHaskell)
@@ -100,6 +97,6 @@ int hs_main ( int argc, char *argv[],       // program args
     END_WINDOWS_VEH_HANDLER
 
     shutdownHaskellAndExit(exit_status, 0 /* !fastExit */);
-    // No code beyond this point. Dead code elimination will remove it 
+    // No code beyond this point. Dead code elimination will remove it
 }
 # endif /* BATCH_MODE */
diff --git a/rts/win32/veh_excn.c b/rts/win32/veh_excn.c
index d925ad8919..e45ea2b49c 100644
--- a/rts/win32/veh_excn.c
+++ b/rts/win32/veh_excn.c
@@ -15,6 +15,57 @@
 // 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,6 +79,7 @@
 
 // Registered exception handler
 PVOID __hs_handle = NULL;
+LPTOP_LEVEL_EXCEPTION_FILTER oldTopFilter = NULL;
 
 long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
 {
@@ -74,32 +126,61 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
     return action;
 }
 
+long WINAPI __hs_exception_filter(struct _EXCEPTION_POINTERS *exception_data)
+{
+    long result = EXCEPTION_CONTINUE_EXECUTION;
+    if (oldTopFilter)
+    {
+        result = (*oldTopFilter)(exception_data);
+        if (EXCEPTION_CONTINUE_SEARCH == result)
+            result = EXCEPTION_CONTINUE_EXECUTION;
+        return result;
+    }
+
+    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.");
     }
 }
 
diff --git a/rts/win32/veh_excn.h b/rts/win32/veh_excn.h
index fda837f1f1..72a9967afd 100644
--- a/rts/win32/veh_excn.h
+++ b/rts/win32/veh_excn.h
@@ -63,6 +63,7 @@
 // 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 );