X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac;hp=4161d9811c39b60b22672e6da319ecc6b8fa957b;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=a40f2735958055f7ff94e5df73e710044aa63b2c diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 4161d98..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, @@ -37,12 +38,11 @@ module InteractiveEval ( #include "HsVersions.h" -import HscMain hiding (compileExpr) -import HsSyn (ImportDecl) +import GhcMonad +import HscMain +import HsSyn import HscTypes -import TcRnDriver -import TcRnMonad (initTc) -import RnNames (gresFromAvails, rnImports) +import RnNames (gresFromAvails) import InstEnv import Type import TcType hiding( typeKind ) @@ -64,18 +64,16 @@ import Panic import UniqFM import Maybes import ErrUtils -import Util 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 @@ -83,7 +81,6 @@ 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 @@ -139,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 @@ -163,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 @@ -173,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 @@ -201,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 @@ -254,7 +242,7 @@ withVirtualCWD m = do 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 @@ -563,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 @@ -589,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. @@ -606,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 @@ -636,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 @@ -777,39 +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 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 + + 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 @@ -837,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. @@ -859,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 @@ -867,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! @@ -911,8 +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 + (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str + liftIO $ hscTcRnLookupRdrName hsc_env rdr_name -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -920,7 +908,7 @@ parseName str = 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 -- ----------------------------------------------------------------------------- @@ -929,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]) @@ -949,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") - ,Nothing):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 @@ -997,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 */