import Linker
import DynFlags
import Unique
+import UniqSupply
import Module
import Panic
-import UniqFM
+import LazyUniqFM
import Maybes
import ErrUtils
import Util
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)
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 ->
-- 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 =
- withInterruptsSentTo
- (forkIO (do res <- Exception.try (rethrow 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.
-- 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
-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
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
handleRunStatus expr ref bindings final_ids
breakMVar statusMVar status hist'
-
back :: Session -> IO ([Name], Int, SrcSpan)
back = moveHist (+1)
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
, 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'
+ 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`
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 */
projects / ghc-hetmet.git / blobdiff