-sandboxIO :: MVar Status -> IO [HValue] -> IO Status
-sandboxIO statusMVar thing =
- withInterruptsSentTo
- (forkIO (do res <- Exception.try thing
- putMVar statusMVar (Complete res)))
- (takeMVar statusMVar)
-
-withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
-withInterruptsSentTo io get_result = do
- ts <- takeMVar interruptTargetThread
- child <- io
- putMVar interruptTargetThread (child:ts)
- get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
-
-withBreakAction breakMVar statusMVar io
- = bracket setBreakAction resetBreakAction (\_ -> io)
+--
+-- Careful here: there may be ^C exceptions flying around, so we start the new
+-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
+-- only while we execute the user's code. We can't afford to lose the final
+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
+sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
+sandboxIO dflags statusMVar thing =
+ mask $ \restore -> do -- fork starts blocked
+ id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing)
+ putMVar statusMVar (Complete res) -- empty: can't block
+ withInterruptsSentTo id $ takeMVar statusMVar
+
+
+-- We want to turn ^C into a break when -fbreak-on-exception is on,
+-- but it's an async exception and we only break for sync exceptions.
+-- Idea: if we catch and re-throw it, then the re-throw will trigger
+-- a break. Great - but we don't want to re-throw all exceptions, because
+-- then we'll get a double break for ordinary sync exceptions (you'd have
+-- to :continue twice, which looks strange). So if the exception is
+-- not "Interrupted", we unset the exception flag before throwing.
+--
+rethrow :: DynFlags -> IO a -> IO a
+rethrow dflags io = Exception.catch io $ \se -> do
+ -- If -fbreak-on-error, we break unconditionally,
+ -- but with care of not breaking twice
+ if dopt Opt_BreakOnError dflags &&
+ not (dopt Opt_BreakOnException dflags)
+ then poke exceptionFlag 1
+ else case fromException se of
+ -- If it is a "UserInterrupt" exception, we allow
+ -- a possible break by way of -fbreak-on-exception
+ Just UserInterrupt -> return ()
+ -- In any other case, we don't want to break
+ _ -> poke exceptionFlag 0
+
+ Exception.throwIO se
+
+withInterruptsSentTo :: ThreadId -> IO r -> IO r
+withInterruptsSentTo thread get_result = do
+ bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
+ (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
+ (\_ -> get_result)
+
+-- This function sets up the interpreter for catching breakpoints, and
+-- resets everything when the computation has stopped running. This
+-- is a not-very-good way to ensure that only the interactive
+-- evaluation should generate breakpoints.
+withBreakAction :: (ExceptionMonad m, MonadIO m) =>
+ Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
+withBreakAction step dflags breakMVar statusMVar act
+ = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)