X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=7014d28122674a4f4351e4d1e74da8c585117d13;hp=6e6580e2487cd727e74099180a3d15c33e9fabca;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=0c45d82423fcff64b43b95ab4882b26e7de560bf diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 6e6580e..7014d28 100644 --- 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`