--
-- -----------------------------------------------------------------------------
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
abandon, abandonAll,
getResumeContext,
getHistorySpan,
+ getModBreaks,
+ getHistoryModule,
back, forward,
setContext, getContext,
nameSetToGlobalRdrEnv,
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1, reconstructType,
+ Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
import Linker
import DynFlags
import Unique
+import UniqSupply
import Module
import Panic
import UniqFM
import Outputable
import Data.Dynamic
+import Data.List (find)
import Control.Monad
import Foreign
import Foreign.C
import Data.Array
import Control.Exception as Exception
import Control.Concurrent
+import Data.List (sortBy)
import Data.IORef
import Foreign.StablePtr
data History
= History {
historyApStack :: HValue,
- historyBreakInfo :: BreakInfo
+ historyBreakInfo :: BreakInfo,
+ historyEnclosingDecl :: Id
+ -- ^^ A cache of the enclosing top level declaration, for convenience
}
-getHistorySpan :: Session -> History -> IO SrcSpan
-getHistorySpan s hist = withSession s $ \hsc_env -> do
- let inf = historyBreakInfo hist
+mkHistory :: HscEnv -> HValue -> BreakInfo -> History
+mkHistory hsc_env hval bi = let
+ h = History hval bi decl
+ decl = findEnclosingDecl hsc_env (getHistoryModule h)
+ (getHistorySpan hsc_env h)
+ in h
+
+getHistoryModule :: History -> Module
+getHistoryModule = breakInfo_module . historyBreakInfo
+
+getHistorySpan :: HscEnv -> History -> SrcSpan
+getHistorySpan hsc_env hist =
+ let inf = historyBreakInfo hist
num = breakInfo_number inf
- case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
- Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
+ in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
+ Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
_ -> panic "getHistorySpan"
+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 (\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.
runStmt :: Session -> String -> SingleStep -> IO RunResult
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)
if b
then handle_normally
else do
- let history' = consBL (History apStack info) history
+ let history' = mkHistory hsc_env apStack info `consBL` history
-- probably better make history strict here, otherwise
-- our BoundedList will be pointless.
evaluate history'
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
_ ->
-- 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 =
+sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
+sandboxIO dflags statusMVar thing =
withInterruptsSentTo
- (forkIO (do res <- Exception.try (rethrow thing)
+ (forkIO (do res <- Exception.try (rethrow dflags thing)
putMVar statusMVar (Complete res)))
(takeMVar statusMVar)
-- 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
return tid)
(takeMVar statusMVar)
-- and wait for the result
- let hist' = case info of
- Nothing -> fromListBL 50 hist
- Just i -> History apStack i `consBL`
- fromListBL 50 hist
+ let hist' =
+ case info of
+ Nothing -> fromListBL 50 hist
+ Just i -> mkHistory hsc_env apStack i `consBL`
+ fromListBL 50 hist
case step of
RunAndLogSteps ->
traceRunStatus expr ref bindings final_ids
handleRunStatus expr ref bindings final_ids
breakMVar statusMVar status hist'
-
back :: Session -> IO ([Name], Int, SrcSpan)
back = moveHist (+1)
resumeBreakInfo = mb_info } ->
update_ic apStack mb_info
else case history !! (new_ix - 1) of
- History apStack info ->
+ History apStack info _ ->
update_ic apStack (Just info)
-- -----------------------------------------------------------------------------
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'
| (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`
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 */