X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=44972d5d36fe9e5d7e5011c1a00da4ec32ad9979;hp=96e0b3484acda8667fc55e9f4b30759dd5874ddf;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hpb=a700f4ed45ddb3a5d16aee62b11febf721c915cc diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 96e0b34..44972d5 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -30,22 +30,23 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, skolemiseSubst, skolemiseTy #endif ) where #ifdef GHCI +#include "HsVersions.h" + import HscMain hiding (compileExpr) import HscTypes import TcRnDriver import Type hiding (typeKind) import TcType hiding (typeKind) import InstEnv -import Var hiding (setIdType) +import Var import Id -import IdInfo import Name hiding ( varName ) import NameSet import RdrName @@ -68,7 +69,9 @@ import RtClosureInspect import BasicTypes import Outputable import FastString +import MonadUtils +import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad @@ -76,11 +79,11 @@ import Foreign import Foreign.C import GHC.Exts import Data.Array -import Control.Exception as Exception +import Exception import Control.Concurrent import Data.List (sortBy) -import Data.IORef import Foreign.StablePtr +import System.IO -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -88,13 +91,13 @@ import Foreign.StablePtr data RunResult = RunOk [Name] -- ^ names bound by this evaluation | RunFailed -- ^ statement failed compilation - | RunException Exception -- ^ statement raised an exception + | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) data Status = Break Bool HValue BreakInfo ThreadId -- ^ the computation hit a breakpoint (Bool <=> was an exception) - | Complete (Either Exception [HValue]) + | Complete (Either SomeException [HValue]) -- ^ the computation completed with either an exception or a value data Resume @@ -117,8 +120,8 @@ data Resume resumeHistoryIx :: Int -- 0 <==> at the top of the history } -getResumeContext :: Session -> IO [Resume] -getResumeContext s = withSession s (return . ic_resume . hsc_IC) +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) data SingleStep = RunToCompletion @@ -182,108 +185,142 @@ findEnclosingDecl hsc_env mod span = -- | Run a statement in the current interactive context. Statement -- may bind multple values. -runStmt :: Session -> String -> SingleStep -> IO RunResult -runStmt (Session ref) expr step - = do - hsc_env <- readIORef ref - - breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint - statusMVar <- newEmptyMVar -- wait on this when a computation is running - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - maybe_stuff <- hscStmt hsc_env' expr - - case maybe_stuff of - Nothing -> return RunFailed - Just (ids, hval) -> do - - status <- - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - sandboxIO dflags' statusMVar thing_to_run +runStmt :: GhcMonad m => String -> SingleStep -> m RunResult +runStmt expr step = + do + hsc_env <- getSession + + breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + r <- 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 + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + liftIO $ sandboxIO dflags' statusMVar thing_to_run - let ic = hsc_IC hsc_env - bindings = (ic_tmp_ids ic, ic_tyvars ic) + let ic = hsc_IC hsc_env + bindings = (ic_tmp_ids ic, ic_tyvars ic) + + case step of + RunAndLogSteps -> + traceRunStatus expr bindings ids + breakMVar statusMVar status emptyHistory + _other -> + handleRunStatus expr bindings ids + breakMVar statusMVar status emptyHistory + +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m - case step of - RunAndLogSteps -> - traceRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory - _other -> - handleRunStatus expr ref bindings ids - breakMVar statusMVar status emptyHistory emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 -handleRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id] +handleRunStatus :: GhcMonad m => + String-> ([Id], TyVarSet) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History - -> IO RunResult -handleRunStatus expr ref bindings final_ids breakMVar statusMVar status + -> m RunResult +handleRunStatus expr bindings final_ids breakMVar statusMVar status history = case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do - hsc_env <- readIORef ref + hsc_env <- getSession let mb_info | is_exception = Nothing | otherwise = Just info - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env - apStack mb_info + (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 hsc_env2 = pushResume hsc_env1 resume -- - writeIORef ref hsc_env2 + modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do - hsc_env <- readIORef ref + hsc_env <- getSession let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids emptyVarSet -- the bound Ids never have any free TyVars final_names = map idName final_ids - Linker.extendLinkEnv (zip final_names hvals) - hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic} - writeIORef ref hsc_env' + liftIO $ Linker.extendLinkEnv (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + modifySession (\_ -> hsc_env') return (RunOk final_names) -traceRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id] +traceRunStatus :: GhcMonad m => + String -> ([Id], TyVarSet) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History - -> IO RunResult -traceRunStatus expr ref bindings final_ids + -> m RunResult +traceRunStatus expr bindings final_ids breakMVar statusMVar status history = do - hsc_env <- readIORef ref + hsc_env <- getSession case status of -- when tracing, if we hit a breakpoint that is not explicitly -- enabled, then we just log the event in the history and continue. (Break is_exception apStack info tid) | not is_exception -> do - b <- isBreakEnabled hsc_env info + b <- liftIO $ isBreakEnabled hsc_env info if b then handle_normally else do let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - evaluate history' - status <- withBreakAction True (hsc_dflags hsc_env) - breakMVar statusMVar $ do - withInterruptsSentTo tid $ do - putMVar breakMVar () -- awaken the stopped thread - takeMVar statusMVar -- and wait for the result - traceRunStatus expr ref bindings final_ids + _ <- liftIO $ evaluate history' + status <- + withBreakAction True (hsc_dflags hsc_env) + breakMVar statusMVar $ do + liftIO $ withInterruptsSentTo tid $ do + putMVar breakMVar () -- awaken the stopped thread + takeMVar statusMVar -- and wait for the result + traceRunStatus expr bindings final_ids breakMVar statusMVar status history' _other -> handle_normally where - handle_normally = handleRunStatus expr ref bindings final_ids + handle_normally = handleRunStatus expr bindings final_ids breakMVar statusMVar status history @@ -315,11 +352,10 @@ foreign import ccall "&rts_breakpoint_io_action" -- 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 only while we execute the user's code. We --- can't afford to lose the final putMVar, otherwise deadlock --- ensues. (#1583, #1922, #1946) +-- 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 +-- 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 @@ -337,24 +373,20 @@ sandboxIO dflags statusMVar thing = -- not "Interrupted", we unset the exception flag before throwing. -- rethrow :: DynFlags -> IO a -> IO a -rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn - case e of +rethrow dflags io = Exception.catch io $ \se -> do -- If -fbreak-on-error, we break unconditionally, -- but with care of not breaking twice - _ | dopt Opt_BreakOnError dflags && - not(dopt Opt_BreakOnException dflags) - -> poke exceptionFlag 1 - - -- If it is an "Interrupted" exception, we allow - -- a possible break by way of -fbreak-on-exception - DynException d | Just Interrupted <- fromDynamic d - -> return () - - -- In any other case, we don't want to break - _ -> poke exceptionFlag 0 - - Exception.throwIO e - + if dopt Opt_BreakOnError dflags && + not (dopt Opt_BreakOnException dflags) + then poke exceptionFlag 1 + else case fromException se of + -- If it is an "Interrupted" exception, we allow + -- a possible break by way of -fbreak-on-exception + Just Interrupted -> return () + -- In any other case, we don't want to break + _ -> poke exceptionFlag 0 + + Exception.throwIO se withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do @@ -366,9 +398,10 @@ withInterruptsSentTo thread get_result = do -- resets everything when the computation has stopped running. This -- is a not-very-good way to ensure that only the interactive -- evaluation should generate breakpoints. -withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a -withBreakAction step dflags breakMVar statusMVar io - = bracket setBreakAction resetBreakAction (\_ -> io) +withBreakAction :: (ExceptionMonad m, MonadIO m) => + Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a +withBreakAction step dflags breakMVar statusMVar act + = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act) where setBreakAction = do stablePtr <- newStablePtr onBreak @@ -398,15 +431,15 @@ noBreakAction :: Bool -> BreakInfo -> HValue -> IO () noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" noBreakAction True _ _ = return () -- exception: just continue -resume :: Session -> SingleStep -> IO RunResult -resume (Session ref) step +resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult +resume canLogSpan step = do - hsc_env <- readIORef ref + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do -- unbind the temporary locals by restoring the TypeEnv from -- before the breakpoint, and drop this Resume from the @@ -415,68 +448,71 @@ resume (Session ref) step ic' = ic { ic_tmp_ids = resume_tmp_ids, ic_tyvars = resume_tyvars, ic_resume = rs } - writeIORef ref hsc_env{ hsc_IC = ic' } + modifySession (\_ -> hsc_env{ hsc_IC = ic' }) -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map idName (filter (`notElem` resume_tmp_ids) (ic_tmp_ids ic)) - Linker.deleteFromLinkEnv new_names + liftIO $ Linker.deleteFromLinkEnv new_names - when (isStep step) $ setStepFlag + when (isStep step) $ liftIO setStepFlag case r of Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ hist _ -> do + final_ids apStack info span hist _ -> do + withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do - status <- withInterruptsSentTo tid $ do + status <- liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- this awakens the stopped thread... takeMVar statusMVar -- and wait for the result - let hist' = - case info of - Nothing -> fromListBL 50 hist - Just i -> mkHistory hsc_env apStack i `consBL` + let prevHistoryLst = fromListBL 50 hist + hist' = case info of + Nothing -> prevHistoryLst + Just i + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of RunAndLogSteps -> - traceRunStatus expr ref bindings final_ids + traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> - handleRunStatus expr ref bindings final_ids + handleRunStatus expr bindings final_ids breakMVar statusMVar status hist' -back :: Session -> IO ([Name], Int, SrcSpan) +back :: GhcMonad m => m ([Name], Int, SrcSpan) back = moveHist (+1) -forward :: Session -> IO ([Name], Int, SrcSpan) +forward :: GhcMonad m => m ([Name], Int, SrcSpan) forward = moveHist (subtract 1) -moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan) -moveHist fn (Session ref) = do - hsc_env <- readIORef ref +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist fn = do + hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do let ix = resumeHistoryIx r history = resumeHistory r new_ix = fn ix -- when (new_ix > length history) $ - throwDyn (ProgramError "no more logged breakpoints") + ghcError (ProgramError "no more logged breakpoints") when (new_ix < 0) $ - throwDyn (ProgramError "already at the beginning of the history") + ghcError (ProgramError "already at the beginning of the history") let update_ic apStack mb_info = do - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env + (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } - writeIORef ref hsc_env1{ hsc_IC = ic' } + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) return (names, new_ix, span) @@ -511,10 +547,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do let exn_fs = fsLit "_exception" exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span e_fs = fsLit "e" - e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol) - exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar) - vanillaIdInfo + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) new_tyvars = unitVarSet e_tyvar ictxt0 = hsc_IC hsc_env @@ -565,8 +600,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- _result in scope at any time. let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span - result_id = Id.mkGlobalId VanillaGlobal result_name result_ty - vanillaIdInfo + 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 @@ -575,18 +609,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : new_ids - | otherwise = new_ids + let result_ok = isPointer result_id + && not (isUnboxedTupleType (idType result_id)) + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - let final_ids = zipWith setIdType all_ids tidy_tys + final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, result_name:names, span) + return (hsc_env1, if result_ok then result_name:names else names, span) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do @@ -600,7 +638,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do loc = nameSrcSpan (idName id) name = mkInternalName uniq occ loc ty = idType id - new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) + new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id) return new_id rttiEnvironment :: HscEnv -> IO HscEnv @@ -608,26 +646,46 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let InteractiveContext{ic_tmp_ids=tmp_ids} = ic incompletelyTypedIds = [id | id <- tmp_ids - , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id) - , isSkolemTyVar v] + , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] - tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds - -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds) - - improvs <- sequence [improveRTTIType hsc_env ty ty' - | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys] - let ic' = foldr (\mb_subst ic' -> - maybe (WARN(True, text ("RTTI failed to calculate the " - ++ "improvement for a type")) ic') - (substInteractiveContext ic' . skolemiseSubst) - mb_subst) - ic - improvs - return hsc_env{hsc_IC=ic'} - -skolemiseSubst :: TvSubst -> TvSubst -skolemiseSubst subst = subst `setTvSubstEnv` - mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst) + hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) + return hsc_env' + where + noSkolems = null . filter isSkolemTyVar . varSetElems . 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 + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + 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 + Nothing -> return $ + WARN(True, text (":print failed to calculate the " + ++ "improvement for a type")) hsc_env + Just subst -> do + when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $ + printForUser stderr alwaysQualify $ + fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] + + let (subst', skols) = skolemiseSubst subst + ic' = extendInteractiveContext + (substInteractiveContext ic subst') [] skols + 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) @@ -660,28 +718,28 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } -- ----------------------------------------------------------------------------- -- Abandoning a resume context -abandon :: Session -> IO Bool -abandon (Session ref) = do - hsc_env <- readIORef ref +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False r:rs -> do - writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } } - abandon_ r + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandon_ r return True -abandonAll :: Session -> IO Bool -abandonAll (Session ref) = do - hsc_env <- readIORef ref +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False rs -> do - writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } } - mapM_ abandon_ rs + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ abandon_ rs return True -- when abandoning a computation we have to @@ -730,21 +788,22 @@ fromListBL bound l = BL (length l) bound l [] -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. -setContext :: Session - -> [Module] -- entire top level scope of these modules - -> [Module] -- exports only of these modules - -> IO () -setContext (Session ref) toplev_mods export_mods = do - hsc_env <- readIORef ref +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 <- mkExportEnv hsc_env export_mods - toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods + 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 - writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = all_env }} + 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 @@ -774,26 +833,26 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not interpreted " + ghcError (ProgramError ("mkTopLevEnv: not interpreted " ++ showSDoc (ppr modl))) Just env -> return env -- | 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 :: Session -> IO ([Module],[Module]) -getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic)) +getContext :: GhcMonad m => m ([Module],[Module]) +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_toplev_scope ic, ic_exports ic) --- | Returns 'True' if the specified module is interpreted, and hence has +-- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. -moduleIsInterpreted :: Session -> Module -> IO Bool -moduleIsInterpreted s modl = withSession s $ \h -> +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> if modulePackageId modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of @@ -805,15 +864,15 @@ moduleIsInterpreted s modl = withSession s $ \h -> -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see Trac #1581) -getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name - = withSession s $ \hsc_env -> - do { mb_stuff <- tcRnGetInfo hsc_env name - ; case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, ispecs) -> do - { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } } +getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) +getInfo name + = withSession $ \hsc_env -> + do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, ispecs) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + 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 @@ -826,12 +885,12 @@ getInfo s name | otherwise = True -- | Returns all names in scope in the current interactive context -getNamesInScope :: Session -> IO [Name] -getNamesInScope s = withSession s $ \hsc_env -> do +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> do return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) -getRdrNamesInScope :: Session -> IO [RdrName] -getRdrNamesInScope s = withSession s $ \hsc_env -> do +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic @@ -858,94 +917,78 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. -parseName :: Session -> String -> IO [Name] -parseName s str = withSession s $ \hsc_env -> do - maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of - Nothing -> return [] - Just (L _ rdr_name) -> do - mb_names <- tcRnLookupRdrName hsc_env rdr_name - case mb_names of - Nothing -> return [] - Just ns -> return ns - -- ToDo: should return error messages +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 :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name +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? -- ----------------------------------------------------------------------------- -- Getting the type of an expression -- | Get the type of an expression -exprType :: Session -> String -> IO (Maybe Type) -exprType s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscTcExpr hsc_env expr - case maybe_stuff of - Nothing -> return Nothing - Just ty -> return (Just tidy_ty) - where - tidy_ty = tidyType emptyTidyEnv ty +exprType :: GhcMonad m => String -> m Type +exprType expr = withSession $ \hsc_env -> do + ty <- hscTcExpr hsc_env expr + return $ tidyType emptyTidyEnv ty -- ----------------------------------------------------------------------------- -- Getting the kind of a type -- | Get the kind of a type -typeKind :: Session -> String -> IO (Maybe Kind) -typeKind s str = withSession s $ \hsc_env -> do - maybe_stuff <- hscKcType hsc_env str - case maybe_stuff of - Nothing -> return Nothing - Just kind -> return (Just kind) +typeKind :: GhcMonad m => String -> m Kind +typeKind str = withSession $ \hsc_env -> do + hscKcType hsc_env str ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue -compileExpr :: Session -> String -> IO (Maybe HValue) -compileExpr s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) - case maybe_stuff of - Nothing -> return Nothing - Just (ids, hval) -> do - -- Run it! - hvals <- (unsafeCoerce# hval) :: IO [HValue] +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = withSession $ \hsc_env -> do + Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) + -- Run it! + hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) - case (ids,hvals) of - ([_],[hv]) -> return (Just hv) - _ -> panic "compileExpr" + case (ids,hvals) of + ([_],[hv]) -> return hv + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- -- Compile an expression into a dynamic -dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) -dynCompileExpr ses expr = do - (full,exports) <- getContext ses - setContext ses full $ +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 ++ ")" - res <- withSession ses (flip hscStmt stmt) - setContext ses full exports - case res of - Nothing -> return Nothing - Just (ids, hvals) -> do - vals <- (unsafeCoerce# hvals :: IO [Dynamic]) - case (ids,vals) of - (_:[], v:[]) -> return (Just v) - _ -> panic "dynCompileExpr" + Just (ids, hvals) <- withSession (flip hscStmt stmt) + setContext full exports + vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) + case (ids,vals) of + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames -showModule :: Session -> ModSummary -> IO String -showModule s mod_summary = withSession s $ \hsc_env -> - isModuleInterpreted s mod_summary >>= \interpreted -> - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) +showModule :: GhcMonad m => ModSummary -> m String +showModule mod_summary = + withSession $ \hsc_env -> do + interpreted <- isModuleInterpreted mod_summary + return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) -isModuleInterpreted :: Session -> ModSummary -> IO Bool -isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> +isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool +isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" Just mod_info -> return (not obj_linkable) @@ -955,23 +998,20 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> ---------------------------------------------------------------------------- -- RTTI primitives -obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term -obtainTerm1 hsc_env force mb_ty x = - cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x) - -obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term -obtainTermB hsc_env bound force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env bound force (Just$ idType id) hv +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +obtainTermFromVal hsc_env bound force ty x = + cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) -obtainTerm :: HscEnv -> Bool -> Id -> IO Term -obtainTerm hsc_env force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env maxBound force (Just$ idType id) hv +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do hv <- Linker.getHValue hsc_env (varName id) - cvReconstructType hsc_env bound (Just$ idType id) hv + cvReconstructType hsc_env bound (idType id) hv + #endif /* GHCI */ +