Convert more UniqFM's back to LazyUniqFM's

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 6e6580e..7014d28 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -64,9 +64,10 @@ import ByteCodeInstr
 import Linker
 import DynFlags
 import Unique
+import UniqSupply
 import Module
 import Panic
-import UniqFM
+import LazyUniqFM
 import Maybes
 import ErrUtils
 import Util
@@ -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 dflags' 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)
@@ -277,10 +278,9 @@ traceRunStatus expr ref bindings final_ids
              evaluate history'
              status <- withBreakAction True (hsc_dflags hsc_env)
                                  breakMVar statusMVar $ do
-                       withInterruptsSentTo
-                         (do putMVar breakMVar ()  -- awaken the stopped thread
-                             return tid)
-                         (takeMVar statusMVar)     -- and wait for the result
+                       withInterruptsSentTo tid $ do
+                           putMVar breakMVar ()  -- awaken the stopped thread
+                           takeMVar statusMVar   -- and wait for the result
              traceRunStatus expr ref bindings final_ids 
                             breakMVar statusMVar status history'
      _other ->
@@ -315,12 +315,19 @@ 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 dflags statusMVar thing = 
-  withInterruptsSentTo 
-        (forkIO (do res <- Exception.try (rethrow dflags thing)
-                    putMVar statusMVar (Complete res)))
-        (takeMVar statusMVar)
+-- 
+-- Careful here: there may be ^C exceptions flying around, so we start
+-- the new thread blocked (forkIO inherits block 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 =
+   block $ do  -- fork starts blocked
+     id <- forkIO $ do res <- Exception.try (unblock $ 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.
@@ -330,7 +337,7 @@ sandboxIO dflags 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 :: 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,
@@ -350,12 +357,11 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 Exception.throwIO e
 
 
-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)
+withInterruptsSentTo :: ThreadId -> IO r -> IO r
+withInterruptsSentTo thread get_result = do
+  bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
+          (\_ -> modifyMVar_ interruptTargetThread (return.tail))
+          (\_ -> get_result)
 
 -- This function sets up the interpreter for catching breakpoints, and
 -- resets everything when the computation has stopped running.  This
@@ -421,11 +427,10 @@ resume (Session ref) step
               final_ids apStack info _ hist _ -> do
                 withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                         breakMVar statusMVar $ do
-                status <- withInterruptsSentTo
-                             (do putMVar breakMVar ()
+                status <- withInterruptsSentTo tid $ do
+                             putMVar breakMVar ()
                                       -- this awakens the stopped thread...
-                                 return tid)
-                             (takeMVar statusMVar)
+                             takeMVar statusMVar
                                       -- and wait for the result 
                 let hist' = 
                      case info of 
@@ -440,7 +445,6 @@ resume (Session ref) step
                         handleRunStatus expr ref bindings final_ids
                                         breakMVar statusMVar status hist'
 
-
 back :: Session -> IO ([Name], Int, SrcSpan)
 back  = moveHist (+1)
 
@@ -582,7 +586,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
@@ -600,10 +610,10 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
    
-   let substs = [computeRTTIsubst ty ty' 
+   let substs = [unifyRTTI ty ty' 
                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
        ic'    = foldr (flip substInteractiveContext) ic 
-                           (map skolemiseSubst $ catMaybes substs)
+                           (map skolemiseSubst substs)
    return hsc_env{hsc_IC=ic'}
 
 skolemiseSubst subst = subst `setTvSubstEnv`