X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=97ddbfd20bb9b15546079f63b4c0148a8e5a20eb;hp=5b19c894fa8a02b1a7526fe0d9e6e0ce4ddad383;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 5b19c89..97ddbfd 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -1,9 +1,18 @@ - +% +% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module LoadIface ( loadInterface, loadInterfaceForName, loadWiredInHomeIface, loadSrcInterface, loadSysInterface, loadOrphanModules, @@ -17,55 +26,41 @@ module LoadIface ( #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst ) + tcIfaceFamInst, tcIfaceVectInfo ) -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 +95,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 +107,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 @@ -126,6 +125,7 @@ loadInterfaceForName doc 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] loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) @@ -142,6 +142,27 @@ loadSysInterface doc mod_name 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.) + + %********************************************************* %* * @@ -183,9 +204,9 @@ loadInterface doc_str mod from -- 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 + other -> do { - { let { hi_boot_file = case from of + let { hi_boot_file = case from of ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot @@ -232,7 +253,7 @@ loadInterface doc_str mod from -- -- The main thing is to add the ModIface to the PIT, but -- we also take the - -- IfaceDecls, IfaceInst, IfaceRules + -- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo -- out of the ModIface and put them into the big EPS pools -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined @@ -245,10 +266,16 @@ 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_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) + (mi_vect_info 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 +287,17 @@ loadInterface doc_str mod from new_eps_insts, eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) new_eps_fam_insts, + eps_vect_info = plusVectInfo (eps_vect_info eps) + new_eps_vect_info, + 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) } @@ -306,7 +344,7 @@ 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 (ifName decl) - ; traceIf (text "Loading decl for " <> ppr main_name) +-- ; traceIf (text "Loading decl for " <> ppr main_name) ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily @@ -319,7 +357,27 @@ loadDecl ignore_prags mod (_version, decl) ; thing <- forkM doc $ do { bumpDeclStats main_name ; tcIfaceDecl ignore_prags decl } - -- Populate the type environment with the implicitTyThings too + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- The delicate point here is that 'mini-env' should be + -- buildable from 'thing' without demanding any of the things 'forkM'd + -- by tcIfaceDecl. For example + -- class C a where { data T a; op :: T a -> Int } + -- We return the bindings + -- [("C", ), ("T", lookup env "T"), ("op", lookup env "op")] + -- The call (lookup env "T") must return the tycon T without first demanding + -- op; because getting the latter will look up T, hence loop. + -- + -- Of course, there is no reason in principle why (lookup env "T") should demand + -- anything do to with op, but take care: + -- (a) implicitTyThings, and + -- (b) getOccName of all the things returned by implicitThings, + -- must not depend on any of the nested type-checks + -- + -- All a bit too finely-balanced for my liking. + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing @@ -338,13 +396,9 @@ loadDecl ignore_prags mod (_version, decl) -- * location -- imported name, to fix the module correctly in the cache mk_new_bndr mod occ - = newGlobalBinder mod occ - (importedSrcLoc (showSDoc (ppr (moduleName mod)))) + = newGlobalBinder mod occ (importedSrcSpan (moduleNameFS (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 @@ -391,18 +445,25 @@ findAndReadIface doc_str mod hi_boot_file -- Look for the file ; hsc_env <- getTopEnv - ; mb_found <- ioToIOEnv (findHiFile hsc_env mod hi_boot_file) + ; mb_found <- ioToIOEnv (findExactModule hsc_env mod) ; case mb_found of { - Failed err -> do + + err | notFound err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts ; returnM (Failed (cannotFindInterface dflags (moduleName mod) err)) } ; - - Succeeded file_path -> do + Found loc mod -> do -- Found file, so read it - { traceIf (ptext SLIT("readIFace") <+> text file_path) + { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) } + + ; if thisPackage dflags == modulePackageId mod + && not (isOneShot (ghcMode dflags)) + then returnM (Failed (homeModError mod loc)) + else do { + + ; traceIf (ptext SLIT("readIFace") <+> text file_path) ; read_result <- readIface mod file_path hi_boot_file ; case read_result of Failed err -> returnM (Failed (badIfaceFile file_path err)) @@ -412,18 +473,10 @@ findAndReadIface doc_str mod hi_boot_file | otherwise -> returnM (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... - }}} - -findHiFile :: HscEnv -> Module -> IsBootInterface - -> IO (MaybeErr FindResult FilePath) -findHiFile hsc_env mod hi_boot_file - = do - maybe_found <- findExactModule hsc_env mod - case maybe_found of - Found loc mod -> return (Succeeded path) - where - path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) - err -> return (Failed err) + }}}} + +notFound (Found _ _) = False +notFound _ = True \end{code} @readIface@ tries just the one file. @@ -467,6 +520,9 @@ 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_vect_info = noVectInfo, 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 } @@ -515,7 +571,7 @@ ifaceStats eps hsep [ int (n_rules_out stats), text "rule decls imported, out of", int (n_rules_in stats), text "read"] ] -\end{code} +\end{code} %************************************************************************ @@ -543,7 +599,9 @@ 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) - <+> int opt_HiVersion + <+> (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") , vcat (map pprExport (mi_exports iface)) , pprDeps (mi_deps iface) @@ -551,9 +609,11 @@ pprModIface 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) - ] + ] where pp_boot | mi_boot iface = ptext SLIT("[boot]") | otherwise = empty @@ -598,10 +658,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 @@ -622,6 +684,17 @@ pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes where pprFix (occ,fix) = ppr fix <+> ppr occ +pprVectInfo :: IfaceVectInfo -> SDoc +pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + }) = + 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) + ] + pprDeprecs NoDeprecs = empty pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) @@ -662,5 +735,12 @@ wrongIfaceModErr iface mod_name file_path ] ] where iface_file = doubleQuotes (text file_path) + +homeModError mod location + = ptext SLIT("attempting to use module ") <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> empty) + <+> ptext SLIT("which is not loaded") \end{code}