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

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b830db6..1f36861 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -72,7 +72,6 @@ import Control.Monad
 import Foreign
 import Foreign.C
 import GHC.Exts
-import GHC.Conc         ( ThreadId(..) )
 import Data.Array
 import Control.Exception as Exception
 import Control.Concurrent
@@ -269,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
@@ -632,7 +647,7 @@ mkExportEnv hsc_env mods = do
 
 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 nameSetToGlobalRdrEnv names mod =
-  mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
+  mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 		 | name <- nameSetToList names ]
 
 vanillaProv :: ModuleName -> Provenance