Don't catch async exceptions when evaluating Template Haskell

(cherry picked from commit df6d42d0c2534fe620798aab01a393dbd40573fb)
(cherry picked from commit 902ece87ffac545451c2a66d145e6c8653e12092)
(cherry picked from commit 629dd56deedcd1162ef5417a9e446f6f1c2b667a)
(cherry picked from commit c703cb398f980a1a799a5a7dbee763db12cc5f7f)

1 files changed, 20 insertions, 3 deletions

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index e62a2bcddf..8a2c490767 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 --
 -- (c) The University of Glasgow 2002-2006
 --
@@ -46,6 +47,8 @@ import Control.Monad
 import qualified Control.Monad.Fail as MonadFail
 import MonadUtils
 import Control.Applicative (Alternative(..))
+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
+import Control.Concurrent (forkIO, killThread)
 
 ----------------------------------------------------------------------
 -- Defining the monad type
@@ -149,12 +152,26 @@ tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
 tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
 tryIOEnvFailure = try
 
--- XXX We shouldn't be catching everything, e.g. timeouts
 tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
--- Catch *all* exceptions
+-- Catch *all* synchronous exceptions
 -- This is used when running a Template-Haskell splice, when
 -- even a pattern-match failure is a programmer error
-tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
+tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env))
+
+-- | Like 'try', but doesn't catch asynchronous exceptions
+safeTry :: IO a -> IO (Either SomeException a)
+safeTry act = do
+  var <- newEmptyMVar
+  -- uninterruptible because we want to mask around 'killThread', which is interruptible.
+  uninterruptibleMask $ \restore -> do
+    -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it
+    t <- forkIO $ try (restore act) >>= putMVar var
+    restore (readMVar var)
+      `catch` \(e :: SomeException) -> do
+        -- Control reaches this point only if the parent thread was sent an async exception
+        -- In that case, kill the 'act' thread and re-raise the exception
+        killThread t
+        throwIO e
 
 tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
 tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))