X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=03ad6deaea80ca1e69c8fe47a1c46fcf252676e1;hb=876a71215ce555d1830aacc51076595a835ad699;hp=707a81d2f3030cb53d4764ec131f2dc1137c1bd4;hpb=046feb1ea3b3dafb21c43fda88778198c1c709d6;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 707a81d..03ad6de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -39,9 +39,9 @@ module GHC ( depanal, load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal workingDirectoryChanged, - checkModule, CheckedModule(..), + checkModule, checkAndLoadModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, + compileToCore, compileToCoreModule, -- * Parsing Haddock comments parseHaddockComment, @@ -74,6 +74,7 @@ module GHC ( setContext, getContext, getNamesInScope, getRdrNamesInScope, + getGRE, moduleIsInterpreted, getInfo, exprType, @@ -92,7 +93,7 @@ module GHC ( InteractiveEval.forward, showModule, isModuleInterpreted, - compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, lookupName, GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, modInfoModBreaks, @@ -211,6 +212,7 @@ import TcRnDriver #endif import TcIface +import TcRnTypes hiding (LIE) import TcRnMonad ( initIfaceCheck ) import Packages import NameSet @@ -234,7 +236,7 @@ import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) import Finder -import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscMain import HscTypes import DynFlags import StaticFlags @@ -244,7 +246,6 @@ import Module import UniqFM import UniqSet import Unique -import PackageConfig import FiniteMap import Panic import Digraph @@ -333,6 +334,7 @@ defaultCleanupHandler dflags inner = -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. +-- ToDo: explain argument [[mb_top_dir]] newSession :: Maybe FilePath -> IO Session newSession mb_top_dir = do -- catch ^C @@ -772,7 +774,7 @@ data CheckedModule = renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo, - coreBinds :: Maybe [CoreBind] + coreModule :: Maybe CoreModule } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -804,28 +806,49 @@ type TypecheckedSource = LHsBinds Id -- If compileToCore is true, it also desugars the module and returns the -- resulting Core bindings as a component of the CheckedModule. checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule) -checkModule (Session ref) mod compileToCore = do - -- parse & typecheck the module +checkModule (Session ref) mod compile_to_core + = do hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env case [ ms | ms <- mg, ms_mod_name ms == mod ] of [] -> return Nothing - (ms:_) -> do - mbChecked <- hscFileCheck - hsc_env{hsc_dflags=ms_hspp_opts ms} - ms compileToCore - case mbChecked of + (ms:_) -> checkModule_ ref ms compile_to_core False + +-- | parses and typechecks a module, optionally generates Core, and also +-- loads the module into the 'Session' so that modules which depend on +-- this one may subsequently be typechecked using 'checkModule' or +-- 'checkAndLoadModule'. If you need to check more than one module, +-- you probably want to use 'checkAndLoadModule'. Constructing the +-- interface takes a little work, so it might be slightly slower than +-- 'checkModule'. +checkAndLoadModule :: Session -> ModSummary -> Bool -> IO (Maybe CheckedModule) +checkAndLoadModule (Session ref) ms compile_to_core + = checkModule_ ref ms compile_to_core True + +checkModule_ :: IORef HscEnv -> ModSummary -> Bool -> Bool + -> IO (Maybe CheckedModule) +checkModule_ ref ms compile_to_core load + = do + let mod = ms_mod_name ms + hsc_env0 <- readIORef ref + let hsc_env = hsc_env0{hsc_dflags=ms_hspp_opts ms} + mb_parsed <- parseFile hsc_env ms + case mb_parsed of Nothing -> return Nothing - Just (HscChecked parsed renamed Nothing _) -> - return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, - typecheckedSource = Nothing, - checkedModuleInfo = Nothing, - coreBinds = Nothing })) - Just (HscChecked parsed renamed - (Just (tc_binds, rdr_env, details)) - maybeCoreBinds) -> do + Just rdr_module -> do + mb_typechecked <- typecheckRenameModule hsc_env ms rdr_module + case mb_typechecked of + Nothing -> return (Just CheckedModule { + parsedSource = rdr_module, + renamedSource = Nothing, + typecheckedSource = Nothing, + checkedModuleInfo = Nothing, + coreModule = Nothing }) + Just (tcg, rn_info) -> do + details <- makeSimpleDetails hsc_env tcg + + let tc_binds = tcg_binds tcg + let rdr_env = tcg_rdr_env tcg let minf = ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet $ @@ -836,19 +859,43 @@ checkModule (Session ref) mod compileToCore = do ,minf_modBreaks = emptyModBreaks #endif } + + mb_guts <- if compile_to_core + then deSugarModule hsc_env ms tcg + else return Nothing + + let mb_core = fmap (\ mg -> + CoreModule { cm_module = mg_module mg, + cm_types = mg_types mg, + cm_binds = mg_binds mg }) + mb_guts + + -- If we are loading this module so that we can typecheck + -- dependent modules, generate an interface and stuff it + -- all in the HomePackageTable. + when load $ do + (iface,_) <- makeSimpleIface hsc_env Nothing tcg details + let mod_info = HomeModInfo { + hm_iface = iface, + hm_details = details, + hm_linkable = Nothing } + let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info + writeIORef ref hsc_env0{ hsc_HPT = hpt_new } + return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, + parsedSource = rdr_module, + renamedSource = rn_info, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf, - coreBinds = maybeCoreBinds})) + coreModule = mb_core })) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and --- desugar the module, then returns the resulting list of Core bindings if --- successful. -compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) -compileToCore session fn = do +-- desugar the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreModule session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -858,16 +905,26 @@ compileToCore session fn = do case maybeModGraph of Nothing -> return Nothing Just modGraph -> do - let modSummary = expectJust "compileToCore" $ - find ((== fn) . msHsFilePath) modGraph - -- Now we have the module name; - -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary - maybeCheckedModule <- checkModule session mod True - case maybeCheckedModule of + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + let mod = ms_mod_name modSummary + maybeCheckedModule <- checkModule session mod True + case maybeCheckedModule of Nothing -> return Nothing - Just checkedMod -> return $ coreBinds checkedMod - -- --------------------------------------------------------------------------- + Just checkedMod -> return $ coreModule checkedMod + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + maybeCoreModule <- compileToCoreModule session fn + return $ fmap cm_binds maybeCoreModule +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -1993,6 +2050,12 @@ lookupGlobalName s name = withSession s $ \hsc_env -> do return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +#ifdef GHCI +-- | get the GlobalRdrEnv for a session +getGRE :: Session -> IO GlobalRdrEnv +getGRE s = withSession s $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +#endif + -- ----------------------------------------------------------------------------- -- Misc exported utils