resume,
abandon, abandonAll,
getResumeContext,
- getHistoryTick,
getHistorySpan,
+ getModBreaks,
getHistoryModule,
- findEnclosingDeclSpanByTick,
back, forward,
setContext, getContext,
nameSetToGlobalRdrEnv,
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1, reconstructType,
+ Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
import Type hiding (typeKind)
import TcType hiding (typeKind)
import InstEnv
-import Var hiding (setIdType)
+import Var
import Id
import IdInfo
import Name hiding ( varName )
import Linker
import DynFlags
import Unique
+import UniqSupply
import Module
import Panic
-import UniqFM
+import LazyUniqFM
import Maybes
import ErrUtils
import Util
import SrcLoc
import BreakArray
import RtClosureInspect
-import Packages
import BasicTypes
import Outputable
+import FastString
import Data.Dynamic
import Data.List (find)
import Foreign.C
import GHC.Exts
import Data.Array
-import Control.Exception as Exception
+import Exception
import Control.Concurrent
+import Data.List (sortBy)
import Data.IORef
import Foreign.StablePtr
data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
+ | RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status
= Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception)
- | Complete (Either Exception [HValue])
+ | Complete (Either SomeException [HValue])
-- ^ the computation completed with either an exception or a value
data Resume
| SingleStep
| RunAndLogSteps
+isStep :: SingleStep -> Bool
isStep RunToCompletion = False
isStep _ = True
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
- historyEnclosingDecl :: Name
+ historyEnclosingDecl :: Id
-- ^^ A cache of the enclosing top level declaration, for convenience
}
(getHistorySpan hsc_env h)
in h
-getHistoryTick :: History -> BreakIndex
-getHistoryTick = breakInfo_number . historyBreakInfo
-
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
let inf = historyBreakInfo hist
num = breakInfo_number inf
in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
- Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num
+ Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
_ -> panic "getHistorySpan"
--- | Finds the enclosing top level function name
-findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Name
+getModBreaks :: HomeModInfo -> ModBreaks
+getModBreaks hmi
+ | Just linkable <- hm_linkable hmi,
+ [BCOs _ modBreaks] <- linkableUnlinked linkable
+ = modBreaks
+ | otherwise
+ = emptyModBreaks -- probably object code
+
+{- | Finds the enclosing top level function name -}
+-- ToDo: a better way to do this would be to keep hold of the decl_path computed
+-- by the coverage pass, which gives the list of lexically-enclosing bindings
+-- for each tick.
+findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
findEnclosingDecl hsc_env mod span =
case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
Nothing -> panic "findEnclosingDecl"
Just hmi -> let
- globals = typeEnvIds (md_types (hm_details hmi))
- Just decl = find (\n -> nameSrcSpan n < span)
- (reverse $ map idName globals)
- -- ^^ assumes md_types is sorted
- in decl
-
--- | Finds the span of the (smallest) function containing this BreakIndex
-findEnclosingDeclSpanByTick :: HscEnv -> Module -> BreakIndex -> SrcSpan
-findEnclosingDeclSpanByTick hsc_env mod tick =
- case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
- Nothing -> panic "findEnclosingDecl"
- Just hmi -> let
- modbreaks = md_modBreaks (hm_details hmi)
- in ASSERT (inRange (bounds modBreaks) tick)
- modBreaks_decls modbreaks ! tick
-
--- | Find the Module corresponding to a FilePath
-findModuleFromFile :: HscEnv -> FilePath -> Maybe Module
-findModuleFromFile hsc_env fp =
- listToMaybe $ [ms_mod ms | ms <- hsc_mod_graph hsc_env
- , ml_hs_file(ms_location ms) == Just (read fp)]
-
+ globals = typeEnvIds (md_types (hm_details hmi))
+ Just decl =
+ find (\id -> let n = idName id in
+ nameSrcSpan n < span && isExternalName n)
+ (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
+ globals)
+ in decl
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
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)
handleRunStatus expr ref bindings ids
breakMVar statusMVar status emptyHistory
-
+emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
+handleRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+ -> MVar () -> MVar Status -> Status -> BoundedList History
+ -> IO RunResult
handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
history =
case status of
writeIORef ref hsc_env'
return (RunOk final_names)
-
+traceRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+ -> MVar () -> MVar Status -> Status -> BoundedList History
+ -> IO RunResult
traceRunStatus expr ref bindings final_ids
breakMVar statusMVar status history = do
hsc_env <- readIORef ref
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 ->
isBreakEnabled hsc_env inf =
case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
Just hmi -> do
- w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
+ w <- getBreak (modBreaks_flags (getModBreaks hmi))
(breakInfo_number inf)
case w of Just n -> return (n /= 0); _other -> return False
_ ->
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
-setStepFlag = poke stepFlag 1
+setStepFlag :: IO ()
+setStepFlag = poke stepFlag 1
+resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
-- this points to the IO action that is executed when a breakpoint is hit
-- 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
+#if __GLASGOW_HASKELL__ < 609
+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
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+ -- If -fbreak-on-error, we break unconditionally,
+ -- but with care of not breaking twice
+ if dopt Opt_BreakOnError dflags &&
+ not (dopt Opt_BreakOnException dflags)
+ then poke exceptionFlag 1
+ else case cast e of
+ -- If it is an "Interrupted" exception, we allow
+ -- a possible break by way of -fbreak-on-exception
+ Just Interrupted -> return ()
+ -- In any other case, we don't want to break
+ _ -> poke exceptionFlag 0
+
+ Exception.throwIO se
+#endif
-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 (\tl -> return $! tail tl))
+ (\_ -> get_result)
-- This function sets up the interpreter for catching breakpoints, and
-- resets everything when the computation has stopped running. This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
+withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a
withBreakAction step dflags breakMVar statusMVar io
= bracket setBreakAction resetBreakAction (\_ -> io)
where
resetStepFlag
freeStablePtr stablePtr
+noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
-noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
-noBreakAction True info apStack = return () -- exception: just continue
+noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
+noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction True _ _ = return () -- exception: just continue
resume :: Session -> SingleStep -> IO RunResult
resume (Session ref) step
resume = ic_resume ic
case resume of
- [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+ [] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
-- unbind the temporary locals by restoring the TypeEnv from
-- before the breakpoint, and drop this Resume from the
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)
forward :: Session -> IO ([Name], Int, SrcSpan)
forward = moveHist (subtract 1)
+moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
moveHist fn (Session ref) = do
hsc_env <- readIORef ref
case ic_resume (hsc_IC hsc_env) of
- [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+ [] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
let ix = resumeHistoryIx r
history = resumeHistory r
new_ix = fn ix
--
when (new_ix > length history) $
- throwDyn (ProgramError "no more logged breakpoints")
+ ghcError (ProgramError "no more logged breakpoints")
when (new_ix < 0) $
- throwDyn (ProgramError "already at the beginning of the history")
+ ghcError (ProgramError "already at the beginning of the history")
let
update_ic apStack mb_info = do
-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
-result_fs = FSLIT("_result")
-
+result_fs :: FastString
+result_fs = fsLit "_result"
+
bindLocalsAtBreakpoint
:: HscEnv
-> HValue
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
- let exn_fs = FSLIT("_exception")
+ let exn_fs = fsLit "_exception"
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
- e_fs = FSLIT("e")
+ e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
- span = mkGeneralSrcSpan FSLIT("<exception thrown>")
+ span = mkGeneralSrcSpan (fsLit "<exception thrown>")
--
Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
let
- mod_name = moduleName (breakInfo_module info)
- mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
- breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
+ mod_name = moduleName (breakInfo_module info)
+ hmi = expectJust "bindLocalsAtBreakpoint" $
+ lookupUFM (hsc_HPT hsc_env) mod_name
+ breaks = getModBreaks hmi
index = breakInfo_number info
vars = breakInfo_vars info
result_ty = breakInfo_resty info
-- So that we don't fall over in a heap when this happens, just don't
-- bind any free variables instead, and we emit a warning.
mb_hValues <- mapM (getIdValFromApStack apStack) offsets
- let (filtered_hvs, filtered_ids) =
- unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
+ let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
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
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
- let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
incompletelyTypedIds =
[id | id <- tmp_ids
, 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'
+ improvs <- sequence [improveRTTIType hsc_env ty ty'
| (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
- ic' = foldr (flip substInteractiveContext) ic
- (map skolemiseSubst $ catMaybes substs)
+ let ic' = foldr (\mb_subst ic' ->
+ maybe (WARN(True, text ("RTTI failed to calculate the "
+ ++ "improvement for a type")) ic')
+ (substInteractiveContext ic' . skolemiseSubst)
+ mb_subst)
+ ic
+ improvs
return hsc_env{hsc_IC=ic'}
+skolemiseSubst :: TvSubst -> TvSubst
skolemiseSubst subst = subst `setTvSubstEnv`
mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []
+consBL :: a -> BoundedList a -> BoundedList a
consBL a (BL len bound left right)
| len < bound = BL (len+1) bound (a:left) right
| null right = BL len bound [a] $! tail (reverse left)
| otherwise = BL len bound (a:left) $! tail right
+toListBL :: BoundedList a -> [a]
toListBL (BL _ _ left right) = left ++ reverse right
+fromListBL :: Int -> [a] -> BoundedList a
fromListBL bound l = BL (length l) bound l []
-- lenBL (BL len _ _ _) = len
-> [Module] -- entire top level scope of these modules
-> [Module] -- exports only of these modules
-> IO ()
-setContext sess@(Session ref) toplev_mods export_mods = do
+setContext (Session ref) toplev_mods export_mods = do
hsc_env <- readIORef ref
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupUFM hpt (moduleName modl) of
- Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
+ Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
showSDoc (ppr modl)))
Just details ->
case mi_globals (hm_iface details) of
Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
+ ghcError (ProgramError ("mkTopLevEnv: not interpreted "
++ showSDoc (ppr modl)))
Just env -> return env
getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
getInfo s name
= withSession s $ \hsc_env ->
- do { mb_stuff <- tcRnGetInfo hsc_env name
- ; case mb_stuff of
- Nothing -> return Nothing
- Just (thing, fixity, ispecs) -> do
- { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
- ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
+ do mb_stuff <- tcRnGetInfo hsc_env name
+ case mb_stuff of
+ Nothing -> return Nothing
+ Just (thing, fixity, ispecs) -> do
+ let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
+ return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
where
plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
= all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
hvals <- (unsafeCoerce# hval) :: IO [HValue]
case (ids,hvals) of
- ([n],[hv]) -> return (Just hv)
+ ([_],[hv]) -> return (Just hv)
_ -> panic "compileExpr"
-- -----------------------------------------------------------------------------
obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 hsc_env force mb_ty x =
- cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+ cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
+
+obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermB hsc_env bound force id = do
+ hv <- Linker.getHValue hsc_env (varName id)
+ cvObtainTerm hsc_env bound force (Just$ idType id) hv
obtainTerm :: HscEnv -> Bool -> Id -> IO Term
obtainTerm hsc_env force id = do
hv <- Linker.getHValue hsc_env (varName id)
- cvObtainTerm hsc_env force (Just$ idType id) hv
+ 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