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

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b830db6..f1e6079 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
@@ -804,11 +819,11 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 		      where
 			 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
-obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 hsc_env force mb_ty x = cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 
-obtainTerm :: Session -> Bool -> Id -> IO Term
-obtainTerm sess force id = withSession sess $ \hsc_env -> do
+obtainTerm :: HscEnv -> Bool -> Id -> IO Term
+obtainTerm hsc_env force id =  do
               hv <- Linker.getHValue hsc_env (varName id) 
               cvObtainTerm hsc_env force (Just$ idType id) hv