From ec53c99c914b874e5957a4ab4fe768f972ff2197 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 10 Oct 2003 12:42:31 +0000 Subject: [PATCH] [project @ 2003-10-10 12:42:30 by simonpj] Arrange that loadImportedRules can see the module dependencies of this module, and hence know whether or not to load an hi-boot interface. --- ghc/compiler/compMan/CompManager.lhs | 22 ++++++++++++++-------- ghc/compiler/iface/LoadIface.lhs | 7 +++---- ghc/compiler/iface/MkIface.lhs | 4 ++-- ghc/compiler/iface/TcIface.lhs | 16 +++++++++++----- ghc/compiler/simplCore/SimplCore.lhs | 14 +++++++------- ghc/compiler/typecheck/TcRnDriver.lhs | 22 ++++++++++++---------- ghc/compiler/typecheck/TcRnMonad.lhs | 12 ++++++++---- 7 files changed, 57 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 149e225..58f2769 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -181,13 +181,15 @@ cmSetContext cmSetContext cmstate toplevs exports = do let old_ic = cm_ic cmstate - export_env <- mkExportEnv (cm_hsc cmstate) - (map mkModuleName exports) + mb_export_env <- mkExportEnv (cm_hsc cmstate) + (map mkModuleName exports) - putStrLn (showSDoc (text "export env" $$ ppr export_env)) - return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, - ic_exports = exports, - ic_rn_gbl_env = export_env } } + case mb_export_env of + Nothing -> return cmstate -- Error already reported; do a no-op + Just export_env -> + return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, + ic_exports = exports, + ic_rn_gbl_env = export_env } } cmGetContext :: CmState -> IO ([String],[String]) cmGetContext CmState{cm_ic=ic} = @@ -219,8 +221,12 @@ cmInfoThing cmstate id cmBrowseModule :: CmState -> String -> Bool -> IO [IfaceDecl] cmBrowseModule cmstate str exports_only - = getModuleContents (cm_hsc cmstate) (cm_ic cmstate) - (mkModuleName str) exports_only + = do { mb_decls <- getModuleContents (cm_hsc cmstate) (cm_ic cmstate) + (mkModuleName str) exports_only + ; case mb_decls of + Nothing -> return [] -- An error of some kind + Just ds -> return ds + } ----------------------------------------------------------------------------- diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 1db091f..9f15797 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -171,14 +171,13 @@ loadInterface doc_str mod_name from -> returnM (Right iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, - -- if an earlier import had a - -- before we got to real imports. I think. + -- if an earlier import had a before we got to real imports. I think. other -> do { if_gbl_env <- getGblEnv ; let { hi_boot_file = case from of ImportByUser usr_boot -> usr_boot - ImportBySystem -> sys_boot + ImportBySystem -> sys_boot ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name ; sys_boot = case mb_dep of @@ -209,7 +208,7 @@ loadInterface doc_str mod_name from WARN( case from of { ImportBySystem -> True; other -> False } && not (isJust mb_dep) && isHomeModule mod, - ppr mod ) + ppr mod $$ ppr mb_dep) initIfaceLcl (moduleName mod) $ do -- Load the new ModIface into the External Package State diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index ddc44c6..97cac77 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -185,7 +185,7 @@ import TcRnMonad import TcRnTypes ( ImportAvails(..), mkModDeps ) import HscTypes ( ModIface(..), ModGuts(..), ModGuts, IfaceExport, - GhciMode(..), + GhciMode(..), noDependencies, HscEnv(..), hscEPS, Dependencies(..), FixItem(..), isImplicitTyThing, @@ -741,7 +741,7 @@ checkOldIface hsc_env mod iface_path source_unchanged maybe_iface = do { showPass (hsc_dflags hsc_env) ("Checking old interface for " ++ moduleUserString mod) ; - ; initIfaceIO hsc_env $ + ; initIfaceIO hsc_env noDependencies {- wrong? -} $ check_old_iface mod iface_path source_unchanged maybe_iface } diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 5fc5399..aaedbac 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -27,7 +27,7 @@ import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, HscEnv, TyThing(..), implicitTyThings, typeEnvIds, - ModIface(..), ModDetails(..), InstPool, + ModIface(..), ModDetails(..), InstPool, Dependencies(..), TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) import InstEnv ( extendInstEnv ) @@ -492,9 +492,9 @@ are in the type environment. However, remember that typechecking a Rule may (as a side effect) augment the type envt, and so we may need to iterate the process. \begin{code} -loadImportedRules :: HscEnv -> IO PackageRuleBase -loadImportedRules hsc_env - = initIfaceIO hsc_env $ do +loadImportedRules :: HscEnv -> Dependencies -> IO PackageRuleBase +loadImportedRules hsc_env deps + = initIfaceIO hsc_env deps $ do { -- Get new rules if_rules <- updateEps (\ eps -> let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) } @@ -510,7 +510,13 @@ loadImportedRules hsc_env ; updateEps (\ eps -> let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules } in (eps { eps_rule_base = new_rule_base }, new_rule_base) - ) } + ) + + -- Strictly speaking, at this point we should go round again, since + -- typechecking one set of rules may bring in new things which enable + -- some more rules to come in. But we call loadImportedRules several + -- times anyway, so I'm going to be lazy and ignore this. + } selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)]) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 28e0b91..1666fdf 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -71,8 +71,7 @@ core2core :: HscEnv core2core hsc_env mod_impl@(ModGuts { mg_exports = exports, - mg_binds = binds_in, - mg_rules = rules_in }) + mg_binds = binds_in }) = do let dflags = hsc_dflags hsc_env ghci_mode = hsc_mode hsc_env @@ -85,7 +84,7 @@ core2core hsc_env -- COMPUTE THE RULE BASE TO USE (rule_base, local_rule_ids, orphan_rules) - <- prepareRules hsc_env ru_us binds_in rules_in + <- prepareRules hsc_env mod_impl ru_us -- PREPARE THE BINDINGS let binds1 = updateBinders ghci_mode local_rule_ids @@ -216,16 +215,17 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } \begin{code} prepareRules :: HscEnv + -> ModGuts -> UniqSupply - -> [CoreBind] - -> [IdCoreRule] -- Local rules -> IO (RuleBase, -- Full rule base IdSet, -- Local rule Ids [IdCoreRule]) -- Orphan rules defined in this module prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) - us binds local_rules - = do { pkg_rule_base <- loadImportedRules hsc_env + (ModGuts { mg_binds = binds, mg_rules = local_rules, + mg_deps = deps }) + us + = do { pkg_rule_base <- loadImportedRules hsc_env deps ; let env = emptySimplEnv SimplGently [] local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 480b28f..29299a7 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -91,7 +91,7 @@ import TyCon ( DataConDetails(..) ) import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnExpr ) import RnNames ( exportsToAvails ) -import LoadIface ( loadSysInterface ) +import LoadIface ( loadSrcInterface ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), tyThingToIfaceDecl ) import IfaceEnv ( tcIfaceGlobal ) @@ -213,7 +213,7 @@ tcRnIface :: HscEnv -> ModIface -- Get the decls from here -> IO ModDetails tcRnIface hsc_env iface - = initIfaceIO hsc_env (typecheckIface iface) + = initIfaceIO hsc_env (mi_deps iface) (typecheckIface iface) \end{code} @@ -573,7 +573,7 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields = HsGroup { hs_tyclds = decls, -- This is the one we want hs_valds = EmptyBinds, hs_fords = [], hs_instds = [], hs_fixds = [], hs_depds = [], - hs_ruleds = [] } + hs_ruleds = [], hs_defds = [] } \end{code} @@ -804,15 +804,15 @@ tcTopSrcDecls \begin{code} #ifdef GHCI mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only - -> IO GlobalRdrEnv + -> IO (Maybe GlobalRdrEnv) mkExportEnv hsc_env exports - = initIfaceIO hsc_env $ do { + = initTc hsc_env iNTERACTIVE $ do { export_envs <- mappM getModuleExports exports ; returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv export_envs) } -getModuleExports :: ModuleName -> IfG GlobalRdrEnv +getModuleExports :: ModuleName -> TcM GlobalRdrEnv getModuleExports mod = do { iface <- load_iface mod ; avails <- exportsToAvails (mi_exports iface) @@ -833,10 +833,10 @@ getModuleContents -> InteractiveContext -> ModuleName -- Module to inspect -> Bool -- Grab just the exports, or the whole toplev - -> IO [IfaceDecl] + -> IO (Maybe [IfaceDecl]) getModuleContents hsc_env ictxt mod exports_only - = initIfaceIO hsc_env (get_mod_contents exports_only) + = initTc hsc_env iNTERACTIVE (get_mod_contents exports_only) where get_mod_contents exports_only | not exports_only -- We want the whole top-level type env @@ -858,7 +858,7 @@ getModuleContents hsc_env ictxt mod exports_only } get_decl avail - = do { thing <- tcIfaceGlobal (availName avail) + = do { thing <- tcLookupGlobal (availName avail) ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) } --------------------- @@ -879,7 +879,9 @@ wantToSee (ADataCon _) = False -- They'll come via their TyCon wantToSee _ = True --------------------- -load_iface mod = loadSysInterface (text "context for compiling statements") mod +load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} + where + doc = ptext SLIT("context for compiling statements") --------------------- noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 5dce531..0f615d8 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -12,7 +12,7 @@ import IOEnv -- Re-export all import HsSyn ( MonoBinds(..) ) import HscTypes ( HscEnv(..), - TyThing, + TyThing, Dependencies(..), ExternalPackageState(..), HomePackageTable, ModDetails(..), HomeModInfo(..), Deprecs(..), FixityEnv, FixItem, @@ -744,10 +744,14 @@ initIfaceExtCore thing_inside } ; setEnvs (if_env, if_lenv) thing_inside } -initIfaceIO :: HscEnv -> IfG a -> IO a -initIfaceIO hsc_env do_this +initIfaceIO :: HscEnv -> Dependencies -> IfG a -> IO a +initIfaceIO hsc_env deps do_this = do { let { - gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv, -- Bogus? + is_boot = mkModDeps (dep_mods deps) + -- Urgh! But we do somehow need to get the info + -- on whether (for this particular compilation) we should + -- import a hi-boot file or not. + ; gbl_env = IfGblEnv { if_is_boot = is_boot, if_rec_types = Nothing } ; } -- 1.7.10.4