X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=13267bd118ce430a002b3118e174ebb3da2378a6;hb=a51fe79ebcdcb8285573a18f12cade2101533419;hp=7e4406e61bceea28cf70cf6a3fd0024072b19aac;hpb=0c41772cba7ec3f558cd2619716c7db771eae935;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 7e4406e..13267bd 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,7 +9,7 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -29,7 +29,6 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, skolemiseSubst, skolemiseTy #endif @@ -40,9 +39,11 @@ module InteractiveEval ( #include "HsVersions.h" import HscMain hiding (compileExpr) +import HsSyn (ImportDecl) import HscTypes import TcRnDriver -import RnNames ( gresFromAvails ) +import TcRnMonad (initTc) +import RnNames (gresFromAvails, rnImports) import InstEnv import Type import TcType hiding( typeKind ) @@ -51,6 +52,7 @@ import Id import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr @@ -74,9 +76,9 @@ import MonadUtils import System.Directory import Data.Dynamic -import Data.List (find) +import Data.List (find, partition) import Control.Monad -import Foreign +import Foreign hiding (unsafePerformIO) import Foreign.C import GHC.Exts import Data.Array @@ -85,6 +87,7 @@ import Control.Concurrent import Data.List (sortBy) -- import Foreign.StablePtr import System.IO +import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -251,6 +254,8 @@ 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 emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -354,13 +359,13 @@ foreign import ccall "&rts_breakpoint_io_action" -- 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) + mask $ \restore -> do -- fork starts blocked + id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing) putMVar statusMVar (Complete res) -- empty: can't block withInterruptsSentTo id $ takeMVar statusMVar @@ -790,21 +795,31 @@ 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 }} + [Module] -- ^ entire top level scope of these modules + -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules + -> m () +setContext toplev_mods other_mods = 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)) + -- + 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 + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods + let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env 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 @@ -841,7 +856,7 @@ 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],[(Module, Maybe (ImportDecl RdrName))]) getContext = withSession $ \HscEnv{ hsc_IC=ic } -> return (ic_toplev_scope ic, ic_exports ic) @@ -918,14 +933,6 @@ 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? - -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -965,7 +972,7 @@ dynCompileExpr expr = do setContext full $ (mkModule (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports + ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" Just (ids, hvals) <- withSession (flip hscStmt stmt) setContext full exports