X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=0d9feb4f8dd463355dddd29e88f57e1052f61a2a;hp=5b19c894fa8a02b1a7526fe0d9e6e0ce4ddad383;hb=4287edeb7f329529149d8c95597d5e418388265f;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 5b19c89..0d9feb4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -1,7 +1,9 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section{Dealing with interface files} + +Loading interface files \begin{code} module LoadIface ( @@ -19,53 +21,39 @@ module LoadIface ( import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst ) -import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) +import DynFlags import IfaceSyn -import IfaceEnv ( newGlobalBinder ) -import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), - Deprecs(..), Dependencies(..), - emptyModIface, EpsStats(..), GenAvailInfo(..), - addEpsInStats, ExternalPackageState(..), - PackageTypeEnv, emptyTypeEnv, HscEnv(..), - lookupIfaceByModule, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, - implicitTyThings - ) - -import BasicTypes ( Version, initialVersion, - Fixity(..), FixityDirection(..), isMarkedStrict ) +import IfaceEnv +import HscTypes + +import BasicTypes hiding (SuccessFlag(..)) import TcRnMonad -import Type ( TyThing(..) ) - -import PrelNames ( gHC_PRIM ) -import PrelInfo ( ghcPrimExports ) -import PrelRules ( builtinRules ) -import Rules ( extendRuleBaseList, mkRuleBase ) -import InstEnv ( emptyInstEnv, extendInstEnvList ) -import FamInstEnv ( emptyFamInstEnv, extendFamInstEnvList ) -import Name ( Name {-instance NamedThing-}, getOccName, - nameModule, nameIsLocalOrFrom, isWiredInName ) +import Type + +import PrelNames +import PrelInfo +import PrelRules +import Rules +import InstEnv +import FamInstEnv +import Name import NameEnv -import MkId ( seqId ) +import MkId import Module -import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc, - mkDataConWrapperOcc, mkDataConWorkerOcc, - mkNewTyCoOcc, mkInstTyCoOcc ) -import SrcLoc ( importedSrcLoc ) -import Maybes ( MaybeErr(..) ) -import ErrUtils ( Message ) -import Finder ( findImportedModule, findExactModule, - FindResult(..), cannotFindInterface ) +import OccName +import SrcLoc +import Maybes +import ErrUtils +import Finder import UniqFM -import StaticFlags ( opt_HiVersion ) +import StaticFlags import Outputable -import BinIface ( readBinIface, v_IgnoreHiWay ) -import Binary -import Panic ( ghcError, showException, GhcException(..) ) -import List ( nub ) -import Maybe ( isJust ) -import DATA_IOREF ( writeIORef ) +import BinIface +import Panic + +import Data.List +import Data.Maybe +import Data.IORef \end{code} @@ -100,8 +88,10 @@ loadSrcInterface doc mod want_boot = do failWithTc (cannotFindInterface dflags mod err) -- | Load interfaces for a collection of orphan modules. -loadOrphanModules :: [Module] -> TcM () -loadOrphanModules mods +loadOrphanModules :: [Module] -- the modules + -> Bool -- these are family instance-modules + -> TcM () +loadOrphanModules mods isFamInstMod | null mods = returnM () | otherwise = initIfaceTcRn $ do { traceIf (text "Loading orphan modules:" <+> @@ -110,7 +100,9 @@ loadOrphanModules mods ; returnM () } where load mod = loadSysInterface (mk_doc mod) mod - mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") + mk_doc mod + | isFamInstMod = ppr mod <+> ptext SLIT("is a family-instance module") + | otherwise = ppr mod <+> ptext SLIT("is a orphan-instance module") -- | Loads the interface for a given Name. loadInterfaceForName :: SDoc -> Name -> TcRn ModIface @@ -246,9 +238,12 @@ loadInterface doc_str mod from ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (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" } } + ; let { final_iface = iface { + 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" + } } ; updateEps_ $ \ eps -> eps { @@ -260,6 +255,15 @@ loadInterface doc_str mod from new_eps_insts, eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) new_eps_fam_insts, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) (length new_eps_insts) (length new_eps_rules) } @@ -342,9 +346,6 @@ loadDecl ignore_prags mod (_version, decl) (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary - ifFamily (IfaceData {ifFamInst = Just (famTyCon, _)}) = Just famTyCon - ifFamily _ = Nothing - doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used @@ -467,6 +468,8 @@ initExternalPackageState eps_fam_inst_env = emptyFamInstEnv, eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules + eps_mod_fam_inst_env + = emptyModuleEnv, 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 } @@ -543,6 +546,7 @@ pprModIface iface <+> ppr (mi_module iface) <+> pp_boot <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) + <+> (if mi_finsts iface then ptext SLIT("[family instance module]") else empty) <+> int opt_HiVersion <+> ptext SLIT("where") , vcat (map pprExport (mi_exports iface)) @@ -598,10 +602,12 @@ pprUsage usage pp_export_version (Just v) = int v pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) + ptext SLIT("orphans:") <+> fsep (map ppr orphs), + ptext SLIT("family instance modules:") <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot