X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=97acc5226ac75bb8154a9fa5c81ce91d4f282e82;hp=ec41e75401351b69b4cfd97346061474ee2688e8;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=c97ae5d4900e5807fe0c8a198a3cad326f2d19c3 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index ec41e75..97acc52 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -8,7 +8,7 @@ Loading interface files \begin{code} module LoadIface ( loadInterface, loadInterfaceForName, loadWiredInHomeIface, - loadSrcInterface, loadSysInterface, loadOrphanModules, + loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, @@ -19,7 +19,7 @@ module LoadIface ( #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst, tcIfaceVectInfo ) + tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations ) import DynFlags import IfaceSyn @@ -28,33 +28,30 @@ import HscTypes import BasicTypes hiding (SuccessFlag(..)) import TcRnMonad -import Type import PrelNames import PrelInfo -import PrelRules +import MkId ( seqId ) import Rules +import Annotations import InstEnv import FamInstEnv import Name import NameEnv -import MkId import Module -import OccName import Maybes import ErrUtils import Finder -import LazyUniqFM +import UniqFM import StaticFlags import Outputable import BinIface import Panic import Util import FastString +import Fingerprint import Control.Monad -import Data.List -import Data.Maybe \end{code} @@ -69,15 +66,20 @@ import Data.Maybe \begin{code} -- | Load the interface corresponding to an @import@ directive in -- source code. On a failure, fail in the monad with an error message. -loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface -loadSrcInterface doc mod want_boot = do +loadSrcInterface :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM ModIface + +loadSrcInterface doc mod want_boot maybe_pkg = do -- We must first find which Module this import refers to. This involves -- calling the Finder, which as a side effect will search the filesystem -- and create a ModLocation. If successful, loadIface will read the -- interface; it will call the Finder again, but the ModLocation will be -- cached from the first search. hsc_env <- getTopEnv - res <- liftIO $ findImportedModule hsc_env mod Nothing + res <- liftIO $ findImportedModule hsc_env mod maybe_pkg case res of Found _ mod -> do mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) @@ -114,49 +116,38 @@ loadInterfaceForName doc name { this_mod <- getModule ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } - ; initIfaceTcRn $ loadSysInterface doc (nameModule name) + ; ASSERT2( isExternalName name, ppr name ) + initIfaceTcRn $ loadSysInterface doc (nameModule name) } -- | An 'IfM' function to load the home interface for a wired-in thing, -- so that we're sure that we see its instance declarations and rules --- See Note [Loading instances] +-- See Note [Loading instances for wired-in things] in TcIface loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) - do loadSysInterface doc (nameModule name); return () + do _ <- loadSysInterface doc (nameModule name); return () where doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name --- | A wrapper for 'loadInterface' that throws an exception if it fails +-- | Loads a system interface and throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -loadSysInterface doc mod_name - = do { mb_iface <- loadInterface doc mod_name ImportBySystem +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = do { mb_iface <- loadInterface doc mod_name where_from ; case mb_iface of Failed err -> ghcError (ProgramError (showSDoc err)) Succeeded iface -> return iface } \end{code} -Note [Loading instances] -~~~~~~~~~~~~~~~~~~~~~~~~ -We need to make sure that we have at least *read* the interface files -for any module with an instance decl or RULE that we might want. - -* If the instance decl is an orphan, we have a whole separate mechanism - (loadOprhanModules) - -* If the instance decl not an orphan, then the act of looking at the - TyCon or Class will force in the defining module for the - TyCon/Class, and hence the instance decl - -* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; - but we must make sure we read its interface in case it has instances or - rules. That is what LoadIface.loadWiredInHomeInterface does. It's called - from TcIface.{tcImportDecl, checkWiredInTyCon, ifCHeckWiredInThing} - -All of this is done by the type checker. The renamer plays no role. -(It used to, but no longer.) - - %********************************************************* %* * @@ -200,19 +191,10 @@ loadInterface doc_str mod from -- if an earlier import had a before we got to real imports. I think. _ -> do { - let { hi_boot_file = case from of - ImportByUser usr_boot -> usr_boot - ImportBySystem -> sys_boot - - ; mb_dep = lookupUFM (eps_is_boot eps) (moduleName mod) - ; sys_boot = case mb_dep of - Just (_, is_boot) -> is_boot - Nothing -> False - -- The boot-ness of the requested interface, - } -- based on the dependencies in directly-imported modules - -- READ THE MODULE IN - ; read_result <- findAndReadIface doc_str mod hi_boot_file + ; read_result <- case (wantHiBootFile dflags eps mod from) of + Failed err -> return (Failed err) + Succeeded hi_boot_file -> findAndReadIface doc_str mod hi_boot_file ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -225,14 +207,15 @@ loadInterface doc_str mod from ; return (Failed err) } ; -- Found and parsed! - Succeeded (iface, file_path) -- Sanity check: - | ImportBySystem <- from, -- system-importing... - modulePackageId (mi_module iface) == thisPackage dflags, - -- a home-package module... - Nothing <- mb_dep -- that we know nothing about - -> return (Failed (badDepMsg mod)) - - | otherwise -> + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, file_path) -> let loc_doc = text file_path @@ -260,6 +243,7 @@ loadInterface doc_str mod from ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface) @@ -267,11 +251,13 @@ loadInterface doc_str mod from mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", mi_fam_insts = panic "No mi_fam_insts in PIT", - mi_rules = panic "No mi_rules in PIT" + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" } } ; updateEps_ $ \ eps -> + if elemModuleEnv mod (eps_PIT eps) then eps else eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, @@ -283,6 +269,8 @@ loadInterface doc_str mod from new_eps_fam_insts, eps_vect_info = plusVectInfo (eps_vect_info eps) new_eps_vect_info, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, eps_mod_fam_inst_env = let fam_inst_env = @@ -300,12 +288,50 @@ loadInterface doc_str mod from ; return (Succeeded final_iface) }}}} +wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom + -> MaybeErr Message IsBootInterface +-- Figure out whether we want Foo.hi or Foo.hi-boot +wantHiBootFile dflags eps mod from + = case from of + ImportByUser usr_boot + | usr_boot && not this_package + -> Failed (badSourceImport mod) + | otherwise -> Succeeded usr_boot + + ImportBySystem + | not this_package -- If the module to be imported is not from this package + -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! + + | otherwise + -> case lookupUFM (eps_is_boot eps) (moduleName mod) of + Just (_, is_boot) -> Succeeded is_boot + Nothing -> Succeeded False + -- The boot-ness of the requested interface, + -- based on the dependencies in directly-imported modules + where + this_package = thisPackage dflags == modulePackageId mod + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package")) + 2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package") + <+> quotes (ppr (modulePackageId mod))) +\end{code} + +{- +Used to be used for the loadInterface sanity check on system imports. That has been removed, but I'm leaving this in pending +review of this decision by SPJ - MCB 10/2008 + badDepMsg :: Module -> SDoc badDepMsg mod = hang (ptext (sLit "Interface file inconsistency:")) 2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"), ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")]) +-} +\begin{code} ----------------------------------------------------- -- Loading type/class/value decls -- We pass the full Module name here, replete with @@ -323,7 +349,7 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv addDeclsToPTE pte things = extendNameEnvList pte things loadDecls :: Bool - -> [(Version, IfaceDecl)] + -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] loadDecls ignore_prags ver_decls = do { mod <- getIfModule @@ -333,7 +359,7 @@ loadDecls ignore_prags ver_decls loadDecl :: Bool -- Don't load pragmas into the decl pool -> Module - -> (Version, IfaceDecl) + -> (Fingerprint, IfaceDecl) -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the -- TyThings are forkM'd thunks loadDecl ignore_prags mod (_version, decl) @@ -407,7 +433,7 @@ loadDecl ignore_prags mod (_version, decl) -- All a bit too finely-balanced for my liking. -- This mini-env and lookup function mediates between the - -- *Name*s n and the map from *OccName*s to the implicit TyThings + --'Name's n and the map from 'OccName's to the implicit TyThings ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing @@ -474,6 +500,9 @@ findAndReadIface doc_str mod hi_boot_file -- Found file, so read it { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) } + -- If the interface is in the current package then if we could + -- load it would already be in the HPT and we assume that our + -- callers checked that. ; if thisPackage dflags == modulePackageId mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) @@ -543,6 +572,7 @@ initExternalPackageState eps_mod_fam_inst_env = emptyModuleEnv, eps_vect_info = noVectInfo, + eps_ann_env = emptyAnnEnv, 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 } @@ -616,33 +646,31 @@ pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface = vcat [ ptext (sLit "interface") - <+> ppr (mi_module iface) <+> pp_boot - <+> ppr (mi_mod_vers iface) <+> pp_sub_vers + <+> ppr (mi_module iface) <+> pp_boot <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty) <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty) <+> (if mi_hpc iface then ptext (sLit "[hpc]") else empty) <+> integer opt_HiVersion - <+> ptext (sLit "where") + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (ptext (sLit "where")) , vcat (map pprExport (mi_exports iface)) , pprDeps (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) + , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) , vcat (map pprIfaceDecl (mi_decls iface)) , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) , pprVectInfo (mi_vect_info iface) - , pprDeprecs (mi_deprecs iface) + , ppr (mi_warns iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") | otherwise = empty - - exp_vers = mi_exp_vers iface - rule_vers = mi_rule_vers iface - - pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) \end{code} When printing export lists, we print like this: @@ -666,16 +694,16 @@ pprExport (mod, items) pp_export names = braces (hsep (map ppr names)) pprUsage :: Usage -> SDoc -pprUsage usage - = hsep [ptext (sLit "import"), ppr (usg_name usage), - int (usg_mod usage), - pp_export_version (usg_exports usage), - int (usg_rules usage), - pp_versions (usg_entities usage) ] - where - pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ] - pp_export_version Nothing = empty - pp_export_version (Just v) = int v +pprUsage usage@UsagePackageModule{} + = hsep [ptext (sLit "import"), ppr (usg_mod usage), + ppr (usg_mod_hash usage)] +pprUsage usage@UsageHomeModule{} + = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), + ppr (usg_mod_hash usage)] $$ + nest 2 ( + maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ + vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] + ) pprDeps :: Dependencies -> SDoc pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, @@ -690,13 +718,9 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, ppr_boot True = text "[boot]" ppr_boot False = empty -pprIfaceDecl :: (Version, IfaceDecl) -> SDoc +pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc pprIfaceDecl (ver, decl) - = ppr_vers ver <+> ppr decl - where - -- Print the version for the decl - ppr_vers v | v == initialVersion = empty - | otherwise = int v + = ppr ver $$ nest 2 (ppr decl) pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = empty @@ -705,22 +729,33 @@ pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes pprFix (occ,fix) = ppr fix <+> ppr occ pprVectInfo :: IfaceVectInfo -> SDoc -pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse +pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = vcat [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars) , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons) , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse) + , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars) + , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons) ] -pprDeprecs :: Deprecations -> SDoc -pprDeprecs NoDeprecs = empty -pprDeprecs (DeprecAll txt) = ptext (sLit "Deprecate all") <+> doubleQuotes (ftext txt) -pprDeprecs (DeprecSome prs) = ptext (sLit "Deprecate") <+> vcat (map pprDeprec prs) - where - pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt) +instance Outputable Warnings where + ppr = pprWarns + +pprWarns :: Warnings -> SDoc +pprWarns NoWarnings = empty +pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt +pprWarns (WarnSome prs) = ptext (sLit "Warnings") + <+> vcat (map pprWarning prs) + where pprWarning (name, txt) = ppr name <+> ppr txt + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized \end{code}