X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac;hp=44972d5d36fe9e5d7e5011c1a00da4ec32ad9979;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=9d0c8f842e35dde3d570580cf62a32779f66a6de diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 44972d5..bb5fab6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,7 +9,8 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, SingleStep(..), + runStmt, runStmtWithLocation, + parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -18,7 +19,7 @@ module InteractiveEval ( getHistoryModule, back, forward, setContext, getContext, - nameSetToGlobalRdrEnv, + availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -29,9 +30,7 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, - Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, - skolemiseSubst, skolemiseTy + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -39,17 +38,20 @@ module InteractiveEval ( #include "HsVersions.h" -import HscMain hiding (compileExpr) +import GhcMonad +import HscMain +import HsSyn import HscTypes -import TcRnDriver -import Type hiding (typeKind) -import TcType hiding (typeKind) +import RnNames (gresFromAvails) import InstEnv +import Type +import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr @@ -59,14 +61,12 @@ import Unique import UniqSupply import Module import Panic -import LazyUniqFM +import UniqFM import Maybes import ErrUtils -import Util import SrcLoc import BreakArray import RtClosureInspect -import BasicTypes import Outputable import FastString import MonadUtils @@ -75,15 +75,15 @@ import System.Directory import Data.Dynamic import Data.List (find) 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 Foreign.StablePtr import System.IO +import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -106,7 +106,7 @@ data Resume 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. @@ -136,16 +136,14 @@ data History = 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 @@ -160,7 +158,7 @@ getHistorySpan hsc_env hist = getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- hm_linkable hmi, [BCOs _ modBreaks] <- linkableUnlinked linkable = modBreaks | otherwise @@ -170,23 +168,24 @@ getModBreaks hmi -- 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 "" 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 @@ -198,20 +197,12 @@ runStmt expr step = 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 @@ -219,7 +210,7 @@ runStmt expr step = 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 -> @@ -250,12 +241,14 @@ withVirtualCWD m = do gbracket set_cwd reset_cwd $ \_ -> m +parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +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 @@ -269,9 +262,12 @@ 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) @@ -281,9 +277,7 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status 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} @@ -291,7 +285,7 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status 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 @@ -351,18 +345,25 @@ foreign import ccall "&rts_breakpoint_io_action" -- 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. @@ -380,9 +381,9 @@ rethrow dflags io = Exception.catch io $ \se -> do not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 else case fromException se of - -- If it is an "Interrupted" exception, we allow + -- If it is a "UserInterrupt" exception, we allow -- a possible break by way of -fbreak-on-exception - Just Interrupted -> return () + Just UserInterrupt -> return () -- In any other case, we don't want to break _ -> poke exceptionFlag 0 @@ -444,9 +445,8 @@ resume canLogSpan step -- 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' }) @@ -458,8 +458,11 @@ resume canLogSpan step 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 @@ -548,12 +551,11 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = 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 "") -- @@ -575,37 +577,41 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do 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. -- 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 + mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) 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" - 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). -- @@ -614,32 +620,36 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do 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 @@ -651,7 +661,7 @@ 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 @@ -663,8 +673,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do 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 @@ -673,32 +682,10 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do 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 @@ -789,43 +776,36 @@ fromListBL bound l = BL (length l) bound l [] -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => - [Module] -- ^ entire top level scope of these modules - -> [Module] -- ^ exports only of these modules - -> m () -setContext toplev_mods export_mods = do - hsc_env <- getSession - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - -- - export_env <- liftIO $ mkExportEnv hsc_env export_mods - toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - modifySession $ \_ -> - hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_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 - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] + [Module] -- ^ entire top level scope of these modules + -> [ImportDecl RdrName] -- ^ these import declarations + -> m () +setContext toplev_mods import_decls = do + hsc_env <- getSession + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + imprt_decls = map noLoc import_decls + -- + 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 import_env toplev_envs + modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_imports = import_decls, + ic_rn_gbl_env = all_env }} + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } @@ -845,9 +825,9 @@ mkTopLevEnv hpt modl -- | 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]) +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. @@ -867,7 +847,7 @@ moduleIsInterpreted modl = withSession $ \h -> 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 @@ -875,7 +855,7 @@ getInfo name 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! @@ -919,16 +899,8 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } -- 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 @@ -936,7 +908,7 @@ lookupName name = withSession $ \hsc_env -> do -- | 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 -- ----------------------------------------------------------------------------- @@ -945,14 +917,14 @@ exprType expr = withSession $ \hsc_env -> do -- | 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]) @@ -965,14 +937,9 @@ compileExpr expr = withSession $ \hsc_env -> do dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do - (full,exports) <- getContext - setContext full $ - (mkModule - (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession (flip hscStmt stmt) - setContext full exports + Just (ids, hvals) <- withSession $ \hsc_env -> + liftIO $ hscStmt hsc_env stmt vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v @@ -1013,5 +980,7 @@ reconstructType hsc_env bound id = do 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 */