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

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 9187f1a..7014d28 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -67,7 +67,7 @@ import Unique
 import UniqSupply
 import Module
 import Panic
-import UniqFM
+import LazyUniqFM
 import Maybes
 import ErrUtils
 import Util
@@ -278,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 ->
@@ -316,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".
+-- 
+-- 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 = 
-  withInterruptsSentTo 
-        (forkIO (do res <- Exception.try (rethrow dflags thing)
-                    putMVar statusMVar (Complete res)))
-        (takeMVar statusMVar)
+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.
@@ -351,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
@@ -422,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 
@@ -606,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`