X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=9187f1a4f9f090385d41a587daa7415311554cf7;hp=8416a86fe74362d505907b501dfd96bfba1790b8;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=e2782137c799a08711cac0844418cc0345a7ceb5

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 8416a86..9187f1a 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -64,6 +64,7 @@ import ByteCodeInstr
 import Linker
 import DynFlags
 import Unique
+import UniqSupply
 import Module
 import Panic
 import UniqFM
@@ -208,10 +209,10 @@ runStmt (Session ref) expr step
 	   Nothing -> return RunFailed
 	   Just (ids, hval) -> do
 
-              withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
-
-              let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-              status <- sandboxIO statusMVar thing_to_run
+              status <- 
+                withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
+                      let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+                      sandboxIO dflags' statusMVar thing_to_run
               
               let ic = hsc_IC hsc_env
                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
@@ -315,10 +316,10 @@ foreign import ccall "&rts_breakpoint_io_action"
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
-sandboxIO :: MVar Status -> IO [HValue] -> IO Status
-sandboxIO statusMVar thing = 
+sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
+sandboxIO dflags statusMVar thing = 
   withInterruptsSentTo 
-        (forkIO (do res <- Exception.try (rethrow thing)
+        (forkIO (do res <- Exception.try (rethrow dflags thing)
                     putMVar statusMVar (Complete res)))
         (takeMVar statusMVar)
 
@@ -330,12 +331,24 @@ sandboxIO statusMVar thing =
 -- 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
+rethrow :: DynFlags -> IO a -> IO a
+rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
+                   -- If -fbreak-on-error, we break unconditionally,
+                   --  but with care of not breaking twice 
+                   _ | dopt Opt_BreakOnError dflags && 
+                       not(dopt Opt_BreakOnException dflags)
+                        -> poke exceptionFlag 1
+
+                   -- If it is an "Interrupted" exception, we allow
+                   --  a possible break by way of -fbreak-on-exception
                    DynException d | Just Interrupted <- fromDynamic d
-                        -> Exception.throwIO e
-                   _ -> do poke exceptionFlag 0; Exception.throwIO e
+                        -> return ()
+
+                   -- In any other case, we don't want to break
+                   _    -> poke exceptionFlag 0
+
+                Exception.throwIO e
 
 
 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
@@ -428,7 +441,6 @@ resume (Session ref) step
                         handleRunStatus expr ref bindings final_ids
                                         breakMVar statusMVar status hist'
 
-
 back :: Session -> IO ([Name], Int, SrcSpan)
 back  = moveHist (+1)
 
@@ -570,7 +582,13 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
   where
    mkNewId :: OccName -> Id -> IO Id
    mkNewId occ id = do
-     let uniq = idUnique id
+     us <- mkSplitUniqSupply 'I'
+        -- we need a fresh Unique for each Id we bind, because the linker
+        -- state is single-threaded and otherwise we'd spam old bindings
+        -- whenever we stop at a breakpoint.  The InteractveContext is properly
+        -- saved/restored, but not the linker state.  See #1743, test break026.
+     let 
+         uniq = uniqFromSupply us
          loc = nameSrcSpan (idName id)
          name = mkInternalName uniq occ loc
          ty = idType id
@@ -585,7 +603,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
                               , isSkolemTyVar v]
                , (occNameFS.nameOccName.idName) id /= result_fs]
-   tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
+   tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
    
    let substs = [computeRTTIsubst ty ty' 
@@ -935,8 +953,8 @@ obtainTerm hsc_env force id =  do
               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
-reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
-reconstructType hsc_env force id = do
+reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
+reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 
-              cvReconstructType hsc_env force (Just$ idType id) hv
+              cvReconstructType hsc_env bound (Just$ idType id) hv
 #endif /* GHCI */