X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=696f612f6bd5479d0474ca89a563fae7668e16ac;hp=687c63c08525e4fd955068940343f5bf5262e3bd;hb=d2f11ea842a25bebd51d6c0c730a756c1d987e25;hpb=bf60bbfb2e76a88265c60a1e9b4f7c2dd1bbfa11 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 687c63c..696f612 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -29,8 +29,7 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, - skolemiseSubst, skolemiseTy + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -38,12 +37,12 @@ module InteractiveEval ( #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 ) @@ -65,7 +64,6 @@ import Panic import UniqFM import Maybes import ErrUtils -import Util import SrcLoc import BreakArray import RtClosureInspect @@ -84,7 +82,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 @@ -110,7 +107,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. @@ -140,16 +137,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 @@ -164,7 +159,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 @@ -174,18 +169,13 @@ 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. @@ -202,20 +192,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 $ hscStmt hsc_env' expr 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 @@ -223,7 +205,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 -> @@ -255,13 +237,13 @@ 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 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 @@ -275,9 +257,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) @@ -287,9 +272,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} @@ -297,7 +280,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 @@ -457,9 +440,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' }) @@ -471,8 +453,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 @@ -563,10 +548,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol) 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 "") -- @@ -616,9 +600,6 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do result_id = Id.mkVanillaGlobal result_name 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). -- @@ -627,12 +608,11 @@ 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)] @@ -664,7 +644,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 @@ -676,8 +656,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 @@ -686,32 +665,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 @@ -816,11 +773,9 @@ setContext toplev_mods other_mods = do 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 $ \_ -> @@ -885,7 +840,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 @@ -937,8 +892,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 @@ -946,7 +901,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 -- ----------------------------------------------------------------------------- @@ -955,14 +910,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]) @@ -981,7 +936,8 @@ dynCompileExpr expr = do (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