X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=13267bd118ce430a002b3118e174ebb3da2378a6;hb=d54de1579e43421350f6282af8977706606973b9;hp=d4230c7313c2aeb3a72561677dc7040038dc8a24;hpb=b06d623b2e367a572de5daf06d6a0b12c2740471;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index d4230c7..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, @@ -18,7 +18,7 @@ module InteractiveEval ( getHistoryModule, back, forward, setContext, getContext, - nameSetToGlobalRdrEnv, + availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -29,7 +29,6 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, skolemiseSubst, skolemiseTy #endif @@ -40,8 +39,11 @@ module InteractiveEval ( #include "HsVersions.h" import HscMain hiding (compileExpr) +import HsSyn (ImportDecl) import HscTypes import TcRnDriver +import TcRnMonad (initTc) +import RnNames (gresFromAvails, rnImports) import InstEnv import Type import TcType hiding( typeKind ) @@ -50,6 +52,7 @@ import Id import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr @@ -59,7 +62,7 @@ import Unique import UniqSupply import Module import Panic -import LazyUniqFM +import UniqFM import Maybes import ErrUtils import Util @@ -73,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 @@ -84,6 +87,7 @@ import Control.Concurrent import Data.List (sortBy) -- import Foreign.StablePtr import System.IO +import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -250,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 @@ -353,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 @@ -380,9 +386,9 @@ rethrow dflags io = Exception.catch io $ \se -> do not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 else case fromException se of - -- If it is an "Interrupted" exception, we allow + -- If it is a "UserInterrupt" exception, we allow -- a possible break by way of -fbreak-on-exception - Just Interrupted -> return () + Just UserInterrupt -> return () -- In any other case, we don't want to break _ -> poke exceptionFlag 0 @@ -789,43 +795,48 @@ 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 -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] +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 } + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } @@ -845,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) @@ -922,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 @@ -969,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