module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
- runStmt, parseImportDecl, SingleStep(..),
+ runStmt, runStmtWithLocation,
+ parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
showModule,
isModuleInterpreted,
compileExpr, dynCompileExpr,
- lookupName,
- Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
- skolemiseSubst, skolemiseTy
+ Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
#endif
) where
#include "HsVersions.h"
-import HscMain hiding (compileExpr)
+import GhcMonad
+import HscMain
import HsSyn (ImportDecl)
import HscTypes
import TcRnDriver
-import TcRnMonad (initTc)
-import RnNames (gresFromAvails, rnImports)
+import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
import UniqFM
import Maybes
import ErrUtils
-import Util
import SrcLoc
import BreakArray
import RtClosureInspect
import Data.Dynamic
import Data.List (find, partition)
import Control.Monad
-import Foreign
+import Foreign hiding (unsafePerformIO)
import Foreign.C
import GHC.Exts
import Data.Array
import Exception
import Control.Concurrent
-import Data.List (sortBy)
-- import Foreign.StablePtr
import System.IO
+import System.IO.Unsafe
-- -----------------------------------------------------------------------------
-- running a statement interactively
resumeThreadId :: ThreadId, -- thread running the computation
resumeBreakMVar :: MVar (),
resumeStatMVar :: MVar Status,
- resumeBindings :: ([Id], TyVarSet),
+ resumeBindings :: [Id],
resumeFinalIds :: [Id], -- [Id] to bind on completion
resumeApStack :: HValue, -- The object from which we can get
-- value of the free variables.
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
- historyEnclosingDecl :: Id
- -- ^^ A cache of the enclosing top level declaration, for convenience
+ historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
}
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
+ decls = findEnclosingDecls hsc_env bi
+ in History hval bi decls
+
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
- | Just linkable <- hm_linkable hmi,
+ | Just linkable <- hm_linkable hmi,
[BCOs _ modBreaks] <- linkableUnlinked linkable
= modBreaks
| otherwise
-- 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
+findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
+findEnclosingDecls hsc_env inf =
+ let hmi = expectJust "findEnclosingDecls" $
+ lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
+ mb = getModBreaks hmi
+ in modBreaks_decls mb ! breakInfo_number inf
+
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
-runStmt expr step =
+runStmt = runStmtWithLocation "<interactive>" 1
+
+-- | Run a statement in the current interactive context. Passing debug information
+-- Statement may bind multple values.
+runStmtWithLocation :: GhcMonad m => String -> Int ->
+ String -> SingleStep -> m RunResult
+runStmtWithLocation source linenumber expr step =
do
hsc_env <- getSession
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
- r <- hscStmt hsc_env' expr
+ r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
case r of
Nothing -> return RunFailed -- empty statement / comment
Just (ids, hval) -> do
- -- XXX: This is the only place we can print warnings before the
- -- result. Is this really the right thing to do? It's fine for
- -- GHCi, but what's correct for other GHC API clients? We could
- -- introduce a callback argument.
- warns <- getWarnings
- liftIO $ printBagOfWarnings dflags' warns
- clearWarnings
-
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
liftIO $ sandboxIO dflags' statusMVar thing_to_run
let ic = hsc_IC hsc_env
- bindings = (ic_tmp_ids ic, ic_tyvars ic)
+ bindings = ic_tmp_ids ic
case step of
RunAndLogSteps ->
gbracket set_cwd reset_cwd $ \_ -> m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
-parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
handleRunStatus :: GhcMonad m =>
- String-> ([Id], TyVarSet) -> [Id]
+ String-> [Id] -> [Id]
-> MVar () -> MVar Status -> Status -> BoundedList History
-> m RunResult
handleRunStatus expr bindings final_ids breakMVar statusMVar status
(hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
mb_info
let
- resume = Resume expr tid breakMVar statusMVar
- bindings final_ids apStack mb_info span
- (toListBL history) 0
+ resume = Resume { resumeStmt = expr, resumeThreadId = tid
+ , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+ , resumeBindings = bindings, resumeFinalIds = final_ids
+ , resumeApStack = apStack, resumeBreakInfo = mb_info
+ , resumeSpan = span, resumeHistory = toListBL history
+ , resumeHistoryIx = 0 }
hsc_env2 = pushResume hsc_env1 resume
--
modifySession (\_ -> hsc_env2)
Left e -> return (RunException e)
Right hvals -> do
hsc_env <- getSession
- let final_ic = extendInteractiveContext (hsc_IC hsc_env)
- final_ids emptyVarSet
- -- the bound Ids never have any free TyVars
+ let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids
final_names = map idName final_ids
liftIO $ Linker.extendLinkEnv (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
return (RunOk final_names)
traceRunStatus :: GhcMonad m =>
- String -> ([Id], TyVarSet) -> [Id]
+ String -> [Id] -> [Id]
-> MVar () -> MVar Status -> Status -> BoundedList History
-> m RunResult
traceRunStatus expr bindings final_ids
-- 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
+-- thread blocked (forkIO inherits mask 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
-
+ mask $ \restore -> -- fork starts blocked
+ let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
+ in if dopt Opt_GhciSandbox dflags
+ then do tid <- forkIO $ do res <- runIt
+ putMVar statusMVar res -- empty: can't block
+ withInterruptsSentTo tid $ takeMVar statusMVar
+ else -- GLUT on OS X needs to run on the main thread. If you
+ -- try to use it from another thread then you just get a
+ -- white rectangle rendered. For this, or anything else
+ -- with such restrictions, you can turn the GHCi sandbox off
+ -- and things will be run in the main thread.
+ runIt
-- 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.
-- unbind the temporary locals by restoring the TypeEnv from
-- before the breakpoint, and drop this Resume from the
-- InteractiveContext.
- let (resume_tmp_ids, resume_tyvars) = resumeBindings r
+ let resume_tmp_ids = resumeBindings r
ic' = ic { ic_tmp_ids = resume_tmp_ids,
- ic_tyvars = resume_tyvars,
ic_resume = rs }
modifySession (\_ -> hsc_env{ hsc_IC = ic' })
when (isStep step) $ liftIO setStepFlag
case r of
- Resume expr tid breakMVar statusMVar bindings
- final_ids apStack info span hist _ -> do
+ Resume { resumeStmt = expr, resumeThreadId = tid
+ , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+ , resumeBindings = bindings, resumeFinalIds = final_ids
+ , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
+ , resumeHistory = hist } -> do
withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
- e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
+ e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
- new_tyvars = unitVarSet e_tyvar
ictxt0 = hsc_IC hsc_env
- ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
+ ictxt1 = extendInteractiveContext ictxt0 [exn_id]
span = mkGeneralSrcSpan (fsLit "<exception thrown>")
--
occs = modBreaks_vars breaks ! index
span = modBreaks_locs breaks ! index
- -- filter out any unboxed ids; we can't bind these at the prompt
- let pointers = filter (\(id,_) -> isPointer id) vars
+ -- Filter out any unboxed ids;
+ -- we can't bind these at the prompt
+ pointers = filter (\(id,_) -> isPointer id) vars
isPointer id | PtrRep <- idPrimRep id = True
| otherwise = False
- let (ids, offsets) = unzip pointers
+ (ids, offsets) = unzip pointers
+
+ free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
+ (tyVarsOfType result_ty) ids
-- It might be that getIdValFromApStack fails, because the AP_STACK
-- has been accidentally evaluated, or something else has gone wrong.
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
- new_ids <- zipWithM mkNewId occs filtered_ids
- let names = map idName new_ids
+ us <- mkSplitUniqSupply 'I'
+ let (us1, us2) = splitUniqSupply us
+ tv_subst = newTyVars us1 free_tvs
+ new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2)
+ names = map idName new_ids
-- make an Id for _result. We use the Unique of the FastString "_result";
-- we don't care about uniqueness here, because there will only be one
-- _result in scope at any time.
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
- result_id = Id.mkVanillaGlobal result_name result_ty
+ result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
-- for each Id we're about to bind in the local envt:
- -- - skolemise the type variables in its type, so they can't
- -- be randomly unified with other types. These type variables
- -- can only be resolved by type reconstruction in RtClosureInspect
-- - tidy the type variables
-- - globalise the Id (Ids are supposed to be Global, apparently).
--
all_ids | result_ok = result_id : new_ids
| otherwise = new_ids
- (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+ id_tys = map idType all_ids
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
- new_tyvars = unionVarSets tyvarss
final_ids = zipWith setIdType all_ids tidy_tys
ictxt0 = hsc_IC hsc_env
- ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
+ ictxt1 = extendInteractiveContext ictxt0 final_ids
Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span)
where
- mkNewId :: OccName -> Id -> IO Id
- mkNewId occ id = do
- us <- mkSplitUniqSupply 'I'
- -- we need a fresh Unique for each Id we bind, because the linker
+ -- 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
- new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
- return new_id
+ mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
+ mkNewId tv_subst occ id uniq
+ = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
+ where
+ loc = nameSrcSpan (idName id)
+ name = mkInternalName uniq occ loc
+ ty = substTy tv_subst (idType id)
+
+ newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
+ -- Similarly, clone the type variables mentioned in the types
+ -- we have here, *and* make them all RuntimeUnk tyars
+ newTyVars us tvs
+ = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
+ | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
+ , let name = setNameUnique (tyVarName tv) uniq ]
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
return hsc_env'
where
- noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
+ noSkolems = isEmptyVarSet . tyVarsOfType . idType
improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
Just id = find (\i -> idName i == name) tmp_ids
case mb_new_ty of
Nothing -> return hsc_env
Just new_ty -> do
- mb_subst <- improveRTTIType hsc_env old_ty new_ty
- case mb_subst of
+ case improveRTTIType hsc_env old_ty new_ty of
Nothing -> return $
WARN(True, text (":print failed to calculate the "
++ "improvement for a type")) hsc_env
printForUser stderr alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
- let (subst', skols) = skolemiseSubst subst
- ic' = extendInteractiveContext
- (substInteractiveContext ic subst') [] skols
+ let ic' = extendInteractiveContext
+ (substInteractiveContext ic subst) []
return hsc_env{hsc_IC=ic'}
-skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
-skolemiseSubst subst = let
- varenv = getTvSubstEnv subst
- all_together = mapVarEnv skolemiseTy varenv
- (varenv', skol_vars) = ( mapVarEnv fst all_together
- , map snd (varEnvElts all_together))
- in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
-
-
-skolemiseTy :: Type -> (Type, TyVarSet)
-skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
- where env = mkVarEnv (zip tyvars new_tyvar_tys)
- subst = mkTvSubst emptyInScopeSet env
- tyvars = varSetElems (tyVarsOfType ty)
- new_tyvars = map skolemiseTyVar tyvars
- new_tyvar_tys = map mkTyVarTy new_tyvars
-
-skolemiseTyVar :: TyVar -> TyVar
-skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
- (SkolemTv RuntimeUnkSkol)
-
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack (stackDepth +# 1#) of
export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
- let imports = rnImports imprt_decls
- this_mod = if null toplev_mods then pRELUDE else head toplev_mods
- (_, env, _,_) <-
- ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
- return env
+ let this_mod | null toplev_mods = pRELUDE
+ | otherwise = head toplev_mods
+ liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
modifySession $ \_ ->
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
= withSession $ \hsc_env ->
- do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
+ do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
case mb_stuff of
Nothing -> return Nothing
Just (thing, fixity, ispecs) -> do
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
+ = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec
where -- A name is ok if it's in the rdr_env,
-- whether qualified or not
ok n | n == name = True -- The one we looked for in the first place!
-- the identifier can refer to in the current interactive context.
parseName :: GhcMonad m => String -> m [Name]
parseName str = withSession $ \hsc_env -> do
- (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
- ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
-
--- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
--- entity known to GHC, including 'Name's defined using 'runStmt'.
-lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
-lookupName name = withSession $ \hsc_env -> do
- mb_tything <- ioMsg $ tcRnLookupName hsc_env name
- return mb_tything
- -- XXX: calls panic in some circumstances; is that ok?
+ (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
+ liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
-- | Get the type of an expression
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
- ty <- hscTcExpr hsc_env expr
+ ty <- liftIO $ hscTcExpr hsc_env expr
return $ tidyType emptyTidyEnv ty
-- -----------------------------------------------------------------------------
-- | Get the kind of a type
typeKind :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
- hscKcType hsc_env str
+ liftIO $ hscKcType hsc_env str
-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
- Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+ Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
-- Run it!
hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
(stringToPackageId "base") (mkModuleName "Data.Dynamic")
,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- Just (ids, hvals) <- withSession (flip hscStmt stmt)
+ Just (ids, hvals) <- withSession $ \hsc_env ->
+ liftIO $ hscStmt hsc_env stmt
setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
+mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
+mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
#endif /* GHCI */