X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac;hp=696f612f6bd5479d0474ca89a563fae7668e16ac;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=e6396ceaf29d592785944ca9f4086595d1137836 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 696f612..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, parseImportDecl, SingleStep(..), + runStmt, runStmtWithLocation, + parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -39,10 +40,9 @@ module InteractiveEval ( 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 ) @@ -67,14 +67,13 @@ import ErrUtils 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 @@ -180,7 +179,13 @@ findEnclosingDecls hsc_env 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 @@ -192,7 +197,7 @@ runStmt expr step = 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 @@ -546,7 +551,7 @@ 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) ictxt0 = hsc_IC hsc_env @@ -572,12 +577,16 @@ 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. @@ -589,15 +598,18 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do 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 @@ -619,20 +631,25 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do 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 @@ -760,37 +777,27 @@ fromListBL bound l = BL (length l) bound l [] -- 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 @@ -818,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, 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. @@ -848,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! @@ -930,15 +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") - ,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 @@ -979,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 */