X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=1f3686186b28f4ee09131058b710cdc7c3da6bb1;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hp=f7e910135eb12851df2dac875378135e90365fe4;hpb=54fd57cdd7c974f81dee81e8edc53e78de82db04;p=ghc-hetmet.git

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index f7e9101..1f36861 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -268,10 +268,26 @@ foreign import ccall "&rts_breakpoint_io_action"
 sandboxIO :: MVar Status -> IO [HValue] -> IO Status
 sandboxIO statusMVar thing = 
   withInterruptsSentTo 
-        (forkIO (do res <- Exception.try thing
+        (forkIO (do res <- Exception.try (rethrow thing)
                     putMVar statusMVar (Complete res)))
         (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 :: IO a -> IO a
+rethrow io = Exception.catch io $ \e -> -- NB. not catchDyn
+                case e of
+                   DynException d | Just Interrupted <- fromDynamic d
+                        -> Exception.throwIO e
+                   _ -> do poke exceptionFlag 0; Exception.throwIO e
+
+
 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
 withInterruptsSentTo io get_result = do
   ts <- takeMVar interruptTargetThread