X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FLoadIface.lhs;h=a760b83bfdd614365703fc49c106a2d6aca4fa45;hb=2daf91758edf8a9a1116ad2ad1468627cf151303;hp=d05d3ae960a323dc56de1b58fa063406ea77e142;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index d05d3ae..a760b83 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -5,72 +5,68 @@ \begin{code} module LoadIface ( - loadHomeInterface, loadInterface, - loadSrcInterface, loadOrphanModules, + loadHomeInterface, loadInterface, loadDecls, + loadSrcInterface, loadOrphanModules, loadHiBootInterface, readIface, -- Used when reading the module's old interface - predInstGates, ifaceInstGates, ifaceStats, + predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, initExternalPackageState ) where #include "HsVersions.h" +import {-# SOURCE #-} TcIface( tcIfaceDecl ) + +import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ), - opt_InPackage ) -import Parser ( parseIface ) - -import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..), - IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) -import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc ) -import HscTypes ( HscEnv(..), ModIface(..), emptyModIface, - ExternalPackageState(..), emptyTypeEnv, emptyPool, - lookupIfaceByModName, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, - Pool(..), DeclPool, InstPool, - RulePool, addRuleToPool, RulePoolContents +import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) +import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), + IfaceConDecls(..), IfaceInst(..), IfaceRule(..), + IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), + IfaceType(..), IfacePredType(..), IfaceExtName, + mkIfaceExtName ) +import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupAvail ) +import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), + addEpsInStats, ExternalPackageState(..), + PackageTypeEnv, emptyTypeEnv, + lookupIfaceByModule, emptyPackageIfaceTable, + IsBootInterface, mkIfaceFixCache, Gated, + implicitTyThings, addRulesToPool, addInstsToPool ) -import BasicTypes ( Version, Fixity(..), FixityDirection(..) ) +import BasicTypes ( Version, Fixity(..), FixityDirection(..), + isMarkedStrict ) import TcType ( Type, tcSplitTyConApp_maybe ) import Type ( funTyCon ) import TcRnMonad -import PrelNames ( gHC_PRIM_Name ) +import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) import Rules ( emptyRuleBase ) import InstEnv ( emptyInstEnv ) import Name ( Name {-instance NamedThing-}, getOccName, - nameModuleName, isInternalName ) + nameModule, isInternalName ) import NameEnv import MkId ( seqId ) -import Packages ( basePackage ) -import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, moduleEnvElts, - extendModuleEnv, lookupModuleEnvByName, moduleUserString +import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, + addBootSuffix_maybe, + extendModuleEnv, lookupModuleEnv, moduleUserString ) -import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, - mkDataConWrapperOcc, mkDataConWorkerOcc ) +import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) import Class ( Class, className ) -import TyCon ( DataConDetails(..), tyConName ) -import SrcLoc ( mkSrcLoc, importedSrcLoc ) -import Maybes ( isJust, mapCatMaybes ) -import StringBuffer ( hGetStringBuffer ) +import TyCon ( tyConName ) +import SrcLoc ( importedSrcLoc ) +import Maybes ( mapCatMaybes, MaybeErr(..) ) import FastString ( mkFastString ) -import ErrUtils ( Message, mkLocMessage ) -import Finder ( findModule, findPackageModule, - hiBootExt, hiBootVerExt ) -import Lexer +import ErrUtils ( Message ) +import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) import Outputable import BinIface ( readBinIface ) -import Panic +import Panic ( ghcError, tryMost, showException, GhcException(..) ) +import List ( nub ) import DATA_IOREF ( readIORef ) - -import Directory \end{code} @@ -83,22 +79,58 @@ import Directory %************************************************************************ \begin{code} -loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface +loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface -- This is called for each 'import' declaration in the source code --- On a failure, fail in the mnad with an error message +-- On a failure, fail in the monad with an error message loadSrcInterface doc mod_name want_boot = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name (ImportByUser want_boot) ; case mb_iface of - Left err -> failWithTc (elaborate err) - Right iface -> return iface + Failed err -> failWithTc (elaborate err) + Succeeded iface -> return iface } where elaborate err = hang (ptext SLIT("Failed to load interface for") <+> quotes (ppr mod_name) <> colon) 4 err -loadOrphanModules :: [ModuleName] -> TcM () +loadHiBootInterface :: TcRn [Name] +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the list of names exported by the hi-boot file +loadHiBootInterface + = do { eps <- getEps + ; mod <- getModule + + ; traceIf (text "loadHiBootInterface" <+> ppr mod) + + -- We're read all the direct imports by now, so eps_is_boot will + -- record if any of our imports mention us by way of hi-boot file + ; case lookupModuleEnv (eps_is_boot eps) mod of { + Nothing -> return [] ; -- The typical case + + Just (_, False) -> -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + failWithTc (moduleLoop mod) ; + + Just (mod_nm, True) -> -- There's a hi-boot interface below us + + + do { -- Load it (into the PTE), and return the exported names + iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True + ; ns_s <- sequenceM [ lookupAvail mod_nm avail + | (mod,avails) <- mi_exports iface, + avail <- avails ] + ; return (concat ns_s) + }}} + where + mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod + <+> ptext SLIT("to compare against the Real Thing") + + moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) + <+> ptext SLIT("depends on itself") + +loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () | otherwise = initIfaceTcRn $ @@ -122,15 +154,15 @@ loadOrphanModules mods loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface loadHomeInterface doc name = ASSERT2( not (isInternalName name), ppr name <+> parens doc ) - loadSysInterface doc (nameModuleName name) + loadSysInterface doc (nameModule name) -loadSysInterface :: SDoc -> ModuleName -> IfM lcl ModIface +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -- A wrapper for loadInterface that Throws an exception if it fails loadSysInterface doc mod_name = do { mb_iface <- loadInterface doc mod_name ImportBySystem ; case mb_iface of - Left err -> ghcError (ProgramError (showSDoc err)) - Right iface -> return iface } + Failed err -> ghcError (ProgramError (showSDoc err)) + Succeeded iface -> return iface } \end{code} @@ -145,8 +177,8 @@ loadSysInterface doc mod_name %********************************************************* \begin{code} -loadInterface :: SDoc -> ModuleName -> WhereFrom - -> IfM lcl (Either Message ModIface) +loadInterface :: SDoc -> Module -> WhereFrom + -> IfM lcl (MaybeErr Message ModIface) -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry -- (to avoid repeated complaints) @@ -154,32 +186,28 @@ loadInterface :: SDoc -> ModuleName -> WhereFrom -- -- It's not necessarily an error for there not to be an interface -- file -- perhaps the module has changed, and that interface --- is no longer used -- but the caller can deal with that by --- catching the exception +-- is no longer used -loadInterface doc_str mod_name from +loadInterface doc_str mod from = do { -- Read the state - env <- getTopEnv - ; let { hpt = hsc_HPT env - ; eps_var = hsc_EPS env } - ; eps <- readMutVar eps_var - ; let { pit = eps_PIT eps } + (eps,hpt) <- getEpsAndHpt + + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModName hpt pit mod_name of { + ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface - -> returnM (Right iface) ; -- Already loaded + -> returnM (Succeeded 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. other -> do - { if_gbl_env <- getGblEnv - ; let { hi_boot_file = case from of + { let { hi_boot_file = case from of ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name + ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -187,30 +215,35 @@ loadInterface doc_str mod_name from } -- based on the dependencies in directly-imported modules -- READ THE MODULE IN - ; read_result <- findAndReadIface doc_str mod_name hi_boot_file + ; let explicit | ImportByUser _ <- from = True + | otherwise = False + ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file + ; dflags <- getDOpts ; case read_result of { - Left err -> do - { let { -- Not found, so add an empty iface to + Failed err -> do + { let fake_iface = emptyModIface HomePackage mod + + ; updateEps_ $ \eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } + -- Not found, so add an empty iface to -- the EPS map so that we don't look again - fake_iface = emptyModIface opt_InPackage mod_name - ; new_pit = extendModuleEnv pit (mi_module fake_iface) fake_iface - ; new_eps = eps { eps_PIT = new_pit } } - ; writeMutVar eps_var new_eps - ; returnM (Left err) } ; + + ; returnM (Failed err) } ; -- Found and parsed! - Right iface -> + Succeeded (iface, file_path) -- Sanity check: + | ImportBySystem <- from, -- system-importing... + isHomePackage (mi_package iface), -- ...a home-package module + Nothing <- mb_dep -- ...that we know nothing about + -> returnM (Failed (badDepMsg mod)) - let { mod = mi_module iface } in + | otherwise -> - -- Sanity check. If we're system-importing a module we know nothing at all - -- about, it should be from a different package to this one - WARN( case from of { ImportBySystem -> True; other -> False } && - not (isJust mb_dep) && - isHomeModule mod, - ppr mod $$ ppr mb_dep) + let + loc_doc = text file_path <+> colon + in + initIfaceLcl mod loc_doc $ do - initIfaceLcl (moduleName mod) $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface -- (which only happens in OneShot mode; in Batch/Interactive @@ -227,21 +260,32 @@ loadInterface doc_str mod_name from -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - { new_eps_decls <- loadDecls mod (eps_decls eps) (mi_decls iface) - ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface) - ; new_eps_rules <- loadRules mod (eps_rules eps) (mi_rules iface) + ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM loadInst (mi_insts iface) + ; new_eps_rules <- if ignore_prags + then return [] + else mapM loadRule (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", - mi_rules = panic "No mi_rules in PIT" } + mi_rules = panic "No mi_rules in PIT" } } + + ; updateEps_ $ \ eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rules = addRulesToPool (eps_rules eps) new_eps_rules, + eps_insts = addInstsToPool (eps_insts eps) new_eps_insts, + eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) + (length new_eps_insts) (length new_eps_rules) } - ; new_eps = eps { eps_PIT = extendModuleEnv pit mod final_iface, - eps_decls = new_eps_decls, - eps_rules = new_eps_rules, - eps_insts = new_eps_insts } } - ; writeMutVar eps_var new_eps - ; return (Right final_iface) - }}}}} + ; return (Succeeded final_iface) + }}}} + +badDepMsg mod + = hang (ptext SLIT("Interface file inconsistency:")) + 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"), + ptext SLIT("but does not appear in the dependencies of the interface")]) ----------------------------------------------------- -- Loading type/class/value decls @@ -252,77 +296,124 @@ loadInterface doc_str mod_name from -- the declaration itself, will find the fully-glorious Name ----------------------------------------------------- -loadDecls :: Module -> DeclPool +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things + +loadDecls :: Bool -> [(Version, IfaceDecl)] - -> IfM lcl DeclPool -loadDecls mod (Pool decls_map n_in n_out) decls - = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls - ; returnM (Pool decls_map' (n_in + length decls) n_out) } - -loadDecl ignore_prags mod decls_map (_version, decl) - = do { main_name <- mk_new_bndr Nothing (ifName decl) - ; let decl' | ignore_prags = zapIdInfo decl - | otherwise = decl - - -- Populate the name cache with final versions of all the subordinate names - ; mapM_ (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl') - - -- Extend the decls pool with a mapping for the main name (only) - ; returnM (extendNameEnv decls_map main_name decl') } + -> IfL [(Name,TyThing)] +loadDecls ignore_prags ver_decls + = do { mod <- getIfModule + ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls + ; return (concat thingss) + } + +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> Module + -> (Version, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks +loadDecl ignore_prags mod (_version, decl) + = do { -- Populate the name cache with final versions of all + -- the names associated with the decl + main_name <- mk_new_bndr mod Nothing (ifName decl) + ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) + + -- Typecheck the thing, lazily + -- NB. firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. + ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl) + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] + lookup n = case lookupOccEnv mini_env (getOccName n) of + Just thing -> thing + Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n) + + ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) } + -- We build a list from the *known* names, with (lookup n) thunks + -- as the TyThings. That way we can extend the PTE without poking the + -- thunks where + stripped_decl | ignore_prags = discardDeclPrags decl + | otherwise = decl + -- mk_new_bndr allocates in the name cache the final canonical -- name for the thing, with the correct - -- * package info -- * parent -- * location -- imported name, to fix the module correctly in the cache - mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc - loc = importedSrcLoc (moduleUserString mod) + mk_new_bndr mod mb_parent occ + = newGlobalBinder mod occ mb_parent + (importedSrcLoc (moduleUserString mod)) + + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) -zapIdInfo decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = DiscardedInfo } -zapIdInfo decl = decl - -- Don't alter "NoInfo", just "HasInfo" +discardDeclPrags :: IfaceDecl -> IfaceDecl +discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo } +discardDeclPrags decl = decl + +bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used +bumpDeclStats name + = do { traceIf (text "Loading decl for" <+> ppr name) + ; updateEps_ (\eps -> let stats = eps_stats eps + in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) + } ----------------- ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names --- Rather revolting, because it has to predict what gets bound +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs }) - = [tc_occ, dc_occ] ++ + = [tc_occ, dc_occ, dcww_occ] ++ [op | IfaceClassOp op _ _ <- sigs] ++ - [mkSuperDictSelOcc n cls_occ | n <- [1..length sc_ctxt]] ++ - -- The worker and wrapper for the DataCon of the class TyCon - -- are based off the data-con name - [mkDataConWrapperOcc dc_occ, mkDataConWorkerOcc dc_occ] + [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] where + n_ctxt = length sc_ctxt + n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ dc_occ = mkClassDataConOcc cls_occ - -ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = [] -ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons}) - = foldr ((++) . conDeclBndrs) [] cons - -ifaceDeclSubBndrs other = [] - -conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields) - = fields ++ - [con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ] - + dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker + | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + +ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon}) + = [] +-- Newtype +ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ, + ifConFields = fields})}) + = fields ++ [con_occ, mkDataConWrapperOcc con_occ] + -- Wrapper, no worker; see MkId.mkDataConIds + +ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) + = nub (concatMap fld_occs cons) -- Eliminate duplicate fields + ++ concatMap dc_occs cons + where + fld_occs (IfVanillaCon { ifConFields = fields }) = fields + fld_occs (IfGadtCon {}) = [] + dc_occs con_decl + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl + strs = ifConStricts con_decl + wrap_occ = mkDataConWrapperOcc con_occ + work_occ = mkDataConWorkerOcc con_occ + has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) + -- ToDo: may miss strictness in existential dicts + +ifaceDeclSubBndrs _other = [] ----------------------------------------------------- -- Loading instance decls ----------------------------------------------------- -loadInsts :: Module -> InstPool -> [IfaceInst] -> IfL InstPool -loadInsts mod (Pool pool n_in n_out) decls - = do { new_pool <- foldlM (loadInstDecl (moduleName mod)) pool decls - ; returnM (Pool new_pool - (n_in + length decls) - n_out) } +loadInst :: IfaceInst -> IfL (Name, Gated IfaceInst) -loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty}) +loadInst decl@(IfaceInst {ifInstHead = inst_ty}) = do { -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then @@ -352,33 +443,25 @@ loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty}) let { (cls_ext, tc_exts) = ifaceInstGates inst_ty } ; cls <- lookupIfaceExt cls_ext ; tcs <- mapM lookupIfaceTc tc_exts - ; let { new_pool = extendNameEnv_C combine pool cls [(tcs, (mod,decl))] - ; combine old _ = (tcs,(mod,decl)) : old } - ; returnM new_pool + ; (mod, doc) <- getIfCtxt + ; returnM (cls, (tcs, (mod, doc, decl))) } ----------------------------------------------------- -- Loading Rules ----------------------------------------------------- -loadRules :: Module -> RulePool -> [IfaceRule] -> IfL RulePool -loadRules mod pool@(Pool rule_pool n_in n_out) rules - = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; if ignore_prags then - returnM pool - else do - { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules - ; returnM (Pool new_pool (n_in + length rules) n_out) } } - -loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents +loadRule :: IfaceRule -> IfL (Gated IfaceRule) -- "Gate" the rule simply by a crude notion of the free vars of -- the LHS. It can be crude, because having too few free vars is safe. -loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) +loadRule decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) = do { names <- mapM lookupIfaceExt (fn : arg_fvs) - ; returnM (addRuleToPool pool (mod_name, decl) names) } + ; (mod, doc) <- getIfCtxt + ; returnM (names, (mod, doc, decl)) } where arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg] + --------------------------- crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName] -- A crude approximation to the free external names of an IfExpr @@ -402,6 +485,11 @@ get_tcs (IfaceTyConApp other ts) = get_tcs_s ts -- The lists are always small => appending is fine get_tcs_s :: [IfaceType] -> [IfaceExtName] get_tcs_s tys = foldr ((++) . get_tcs) [] tys + + +---------------- +getIfCtxt :: IfL (Module, SDoc) +getIfCtxt = do { env <- getLclEnv; return (if_mod env, if_loc env) } \end{code} @@ -428,11 +516,11 @@ ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon]) ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t -ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys +ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = (cls, instHeadTyconGates tys) ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other) -- The other cases should not happen -instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys) +instHeadTyconGates tys = mapCatMaybes root_tycon tys where root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName) root_tycon (IfaceTyConApp tc _) = Just tc @@ -459,17 +547,18 @@ predInstGates cls tys %********************************************************* \begin{code} -findAndReadIface :: SDoc -> ModuleName +findAndReadIface :: Bool -- True <=> explicit user import + -> SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> IfM lcl (Either Message ModIface) + -> IfM lcl (MaybeErr Message (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface doc_str mod_name hi_boot_file +findAndReadIface explicit doc_str mod_name hi_boot_file = do { traceIf (sep [hsep [ptext SLIT("Reading"), if hi_boot_file then ptext SLIT("[boot]") @@ -479,31 +568,39 @@ findAndReadIface doc_str mod_name hi_boot_file nest 4 (ptext SLIT("reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface - ; if mod_name == gHC_PRIM_Name - then returnM (Right ghcPrimIface) + ; dflags <- getDOpts + ; let base_pkg = basePackageId (pkgState dflags) + ; if mod_name == gHC_PRIM + then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg }, + "")) else do -- Look for the file - ; mb_found <- ioToIOEnv (findHiFile mod_name hi_boot_file) + ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file) ; case mb_found of { - Left files -> do + Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) } ; + ; returnM (Failed (cantFindError dflags mod_name err)) } ; - Right file_path -> do + Succeeded (file_path, pkg) -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) ; read_result <- readIface mod_name file_path hi_boot_file ; case read_result of - Left err -> returnM (Left (badIfaceFile file_path err)) - Right iface -> returnM (Right iface) + Failed err -> returnM (Failed (badIfaceFile file_path err)) + Succeeded iface + | mi_module iface /= mod_name -> + return (Failed (wrongIfaceModErr iface mod_name file_path)) + | otherwise -> + returnM (Succeeded (iface{mi_package=pkg}, file_path)) + -- Don't forget to fill in the package name... }}} -findHiFile :: ModuleName -> IsBootInterface - -> IO (Either [FilePath] FilePath) -findHiFile mod_name hi_boot_file +findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface + -> IO (MaybeErr FindResult (FilePath, PackageIdH)) +findHiFile dflags explicit mod_name hi_boot_file = do { -- In interactive or --make mode, we are *not allowed* to demand-load -- a home package .hi file. So don't even look for them. @@ -511,67 +608,42 @@ findHiFile mod_name hi_boot_file -- and start up GHCi - it won't complain that all the modules it tries -- to load are found in the home location. ghci_mode <- readIORef v_GhcMode ; - let { home_allowed = hi_boot_file || - not (isCompManagerMode ghci_mode) } ; + let { home_allowed = not (isCompManagerMode ghci_mode) } ; maybe_found <- if home_allowed - then findModule mod_name - else findPackageModule mod_name ; - - case maybe_found of { - Left files -> return (Left files) ; - - Right (_, loc) -> do { -- Don't need module returned by finder - - -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate - let { hi_path = ml_hi_file loc ; - hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; - hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt - }; - - if not hi_boot_file then - return (Right hi_path) - else do { - hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right hi_boot_ver_path) - else return (Right hi_boot_path) - }}}} + then findModule dflags mod_name explicit + else findPackageModule dflags mod_name explicit; + + case maybe_found of + Found loc pkg -> return (Succeeded (path, pkg)) + where + path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + + err -> return (Failed err) + } \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: ModuleName -> String -> IsBootInterface - -> IfM lcl (Either Message ModIface) - -- Left err <=> file not found, or unreadable, or illegible - -- Right iface <=> successfully found and parsed +readIface :: Module -> String -> IsBootInterface + -> IfM lcl (MaybeErr Message ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed -readIface wanted_mod_name file_path is_hi_boot_file +readIface wanted_mod file_path is_hi_boot_file = do { dflags <- getDOpts - ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) } - -read_iface dflags wanted_mod file_path is_hi_boot_file - | is_hi_boot_file -- Read ascii - = do { res <- tryMost (hGetStringBuffer file_path) ; - case res of { - Left exn -> return (Left (text (showException exn))) ; - Right buffer -> - case unP parseIface (mkPState buffer loc dflags) of - PFailed span err -> return (Left (mkLocMessage span err)) - POk _ iface - | wanted_mod == actual_mod -> return (Right iface) - | otherwise -> return (Left err) - where - actual_mod = moduleName (mi_module iface) - err = hiModuleNameMismatchWarn wanted_mod actual_mod - }} - - | otherwise -- Read binary - = do { res <- tryMost (readBinIface file_path) + ; ioToIOEnv $ do + { res <- tryMost (readBinIface file_path) ; case res of - Right iface -> return (Right iface) - Left exn -> return (Left (text (showException exn))) } - where - loc = mkSrcLoc (mkFastString file_path) 1 0 + Right iface + | wanted_mod == actual_mod -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + }} \end{code} @@ -585,21 +657,22 @@ read_iface dflags wanted_mod file_path is_hi_boot_file initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { + eps_is_boot = emptyModuleEnv, eps_PIT = emptyPackageIfaceTable, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_rule_base = emptyRuleBase, - eps_decls = emptyPool emptyNameEnv, - eps_insts = emptyPool emptyNameEnv, - eps_rules = foldr add (emptyPool []) builtinRules + eps_insts = emptyNameEnv, + eps_rules = addRulesToPool [] (map mk_gated_rule builtinRules), + -- Initialise the EPS rule pool with the built-in rules + eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 + , n_insts_in = 0, n_insts_out = 0 + , n_rules_in = length builtinRules, n_rules_out = 0 } } where - -- Initialise the EPS rule pool with the built-in rules - add (fn_name, core_rule) (Pool rules n_in n_out) - = Pool rules' (n_in+1) n_out - where - rules' = addRuleToPool rules iface_rule [fn_name] - iface_rule = (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule) + mk_gated_rule (fn_name, core_rule) + = ([fn_name], (nameModule fn_name, ptext SLIT(""), + IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) \end{code} @@ -612,8 +685,8 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface basePackage gHC_PRIM_Name) { - mi_exports = [(gHC_PRIM_Name, ghcPrimExports)], + = (emptyModIface HomePackage gHC_PRIM) { + mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, mi_fix_fn = mkIfaceFixCache fixities @@ -632,23 +705,17 @@ ghcPrimIface \begin{code} ifaceStats :: ExternalPackageState -> SDoc ifaceStats eps - = hcat [text "Renamer stats: ", stats] + = hcat [text "Renamer stats: ", msg] where - n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)] - -- This is really only right for a one-shot compile - - Pool _ n_decls_in n_decls_out = eps_decls eps - Pool _ n_insts_in n_insts_out = eps_insts eps - Pool _ n_rules_in n_rules_out = eps_rules eps - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int n_decls_out, text "type/class/variable imported, out of", - int n_decls_in, text "read"], - hsep [ int n_insts_out, text "instance decls imported, out of", - int n_insts_in, text "read"], - hsep [ int n_rules_out, text "rule decls imported, out of", - int n_rules_in, text "read"] + stats = eps_stats eps + msg = vcat + [int (n_ifaces_in stats) <+> text "interfaces read", + hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", + int (n_decls_in stats), text "read"], + hsep [ int (n_insts_out stats), text "instance decls imported, out of", + int (n_insts_in stats), text "read"], + hsep [ int (n_rules_out stats), text "rule decls imported, out of", + int (n_rules_in stats), text "read"] ] \end{code} @@ -664,7 +731,7 @@ badIfaceFile file err = vcat [ptext SLIT("Bad interface file:") <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn :: Module -> Module -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") , ppr requested_mod @@ -672,13 +739,14 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] -noIfaceErr dflags mod_name boot_file files - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra - where - extra - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) +wrongIfaceModErr iface mod_name file_path + = sep [ptext SLIT("Interface file") <+> iface_file, + ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma, + ptext SLIT("but we were expecting module") <+> quotes (ppr mod_name), + sep [ptext SLIT("Probable cause: the source code which generated"), + nest 2 iface_file, + ptext SLIT("has an incompatible module name") + ] + ] + where iface_file = doubleQuotes (text file_path) \end{code}