module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
- runStmt, parseImportDecl, SingleStep(..),
+ runStmt, runStmtWithLocation,
+ parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
import GhcMonad
import HscMain
-import HsSyn (ImportDecl)
+import HsSyn
import HscTypes
-import TcRnDriver
-import RnNames (gresFromAvails)
+import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
import SrcLoc
import BreakArray
import RtClosureInspect
-import BasicTypes
import Outputable
import FastString
import MonadUtils
import System.Directory
import Data.Dynamic
-import Data.List (find, partition)
+import Data.List (find)
import Control.Monad
import Foreign hiding (unsafePerformIO)
import Foreign.C
-- | 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 <- liftIO $ hscStmt hsc_env' expr
+ r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
case r of
Nothing -> return RunFailed -- empty statement / comment
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)
ictxt0 = hsc_IC hsc_env
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:
-- - tidy the type variables
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
-- module. They always shadow anything in scope in the current context.
setContext :: GhcMonad m =>
[Module] -- ^ entire top level scope of these modules
- -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
+ -> [ImportDecl RdrName] -- ^ these import declarations
-> m ()
-setContext toplev_mods other_mods = do
+setContext toplev_mods import_decls = do
hsc_env <- getSession
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
- (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
- export_mods = map fst mods
- imprt_decls = map noLoc (catMaybes (map snd decls))
+ imprt_decls = map noLoc import_decls
--
- export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
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
+
+ let all_env = foldr plusGlobalRdrEnv import_env toplev_envs
modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = other_mods,
- ic_rn_gbl_env = all_env }}
-
--- Make a GlobalRdrEnv based on the exports of the modules only.
-mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
-mkExportEnv hsc_env mods
- = do { stuff <- mapM (getModuleExports hsc_env) mods
- ; let (_msgs, mb_name_sets) = unzip stuff
- envs = [ availsToGlobalRdrEnv (moduleName mod) avails
- | (Just avails, mod) <- zip mb_name_sets mods ]
- ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
+ ic_imports = import_decls,
+ ic_rn_gbl_env = all_env }}
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
-getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
+getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName])
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic)
+ return (ic_toplev_scope ic, ic_imports ic)
-- | Returns @True@ if the specified module is interpreted, and hence has
-- its full top-level scope available.
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!
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
- (full,exports) <- getContext
- setContext full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
- setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
(_:[], v:[]) -> return v
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 */
projects / ghc-hetmet.git / blobdiff