X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=50fa9335820af94e17b20cb87e390b402b589ef6;hp=e4ac07506a1fb3ddd079e2038480e03370ee3e9e;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=9636f8cd435e598132687fc1e007c181f2f221e6 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e4ac075..50fa933 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -6,13 +6,6 @@ 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, @@ -48,19 +41,21 @@ import NameEnv import MkId import Module import OccName -import SrcLoc import Maybes import ErrUtils import Finder -import UniqFM +import LazyUniqFM import StaticFlags import Outputable import BinIface import Panic +import Util +import FastString +import Fingerprint +import Control.Monad import Data.List import Data.Maybe -import Data.IORef \end{code} @@ -75,15 +70,20 @@ import Data.IORef \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 <- ioToIOEnv $ 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) @@ -99,29 +99,30 @@ loadOrphanModules :: [Module] -- the modules -> Bool -- these are family instance-modules -> TcM () loadOrphanModules mods isFamInstMod - | null mods = returnM () + | null mods = return () | otherwise = initIfaceTcRn $ do { traceIf (text "Loading orphan modules:" <+> fsep (map ppr mods)) - ; mappM_ load mods - ; returnM () } + ; mapM_ load mods + ; return () } where load mod = loadSysInterface (mk_doc mod) mod mk_doc mod - | isFamInstMod = ppr mod <+> ptext SLIT("is a family-instance module") - | otherwise = ppr mod <+> ptext SLIT("is a orphan-instance module") + | 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 loadInterfaceForName doc name - = do { -#ifdef DEBUG - -- Should not be called with a name from the module being compiled - this_mod <- getModule - ; ASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) -#endif - initIfaceTcRn $ loadSysInterface doc (nameModule name) - } + = do { + when debugIsOn $ do + -- Should not be called with a name from the module being compiled + { this_mod <- getModule + ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) + } + ; 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 @@ -131,7 +132,7 @@ loadWiredInHomeIface name = ASSERT( isWiredInName name ) do loadSysInterface doc (nameModule name); return () where - doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name + doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name -- | A wrapper for 'loadInterface' that throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface @@ -200,11 +201,11 @@ loadInterface doc_str mod from ; dflags <- getDOpts ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { Just iface - -> returnM (Succeeded iface) ; -- Already loaded + -> return (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 { + _ -> do { let { hi_boot_file = case from of ImportByUser usr_boot -> usr_boot @@ -228,7 +229,7 @@ loadInterface doc_str mod from -- Not found, so add an empty iface to -- the EPS map so that we don't look again - ; returnM (Failed err) } ; + ; return (Failed err) } ; -- Found and parsed! Succeeded (iface, file_path) -- Sanity check: @@ -236,7 +237,7 @@ loadInterface doc_str mod from modulePackageId (mi_module iface) == thisPackage dflags, -- a home-package module... Nothing <- mb_dep -- that we know nothing about - -> returnM (Failed (badDepMsg mod)) + -> return (Failed (badDepMsg mod)) | otherwise -> @@ -300,15 +301,17 @@ loadInterface doc_str mod from fam_inst_env, eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) - (length new_eps_insts) (length new_eps_rules) } + (length new_eps_insts) + (length new_eps_rules) } ; return (Succeeded final_iface) }}}} +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")]) + = 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")]) ----------------------------------------------------- -- Loading type/class/value decls @@ -327,7 +330,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 @@ -337,7 +340,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) @@ -357,40 +360,74 @@ 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. - -- - -- 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. - + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ , ] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> , "x" -> , ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implict_names to the associated + -- TyThings. By the invariant on ifaceDeclSubBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implictTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> , 'x' -> , ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implictTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of on the way to + -- extracting 's OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- 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 ; 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 $$ ppr (decl)) - ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + ; return $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implictTyThings are bijective + [(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 - doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) + doc = ptext (sLit "Declaration for") <+> ppr (ifName decl) bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used bumpDeclStats name @@ -419,31 +456,26 @@ findAndReadIface :: SDoc -> Module -- sometimes it's ok to fail... see notes with loadInterface findAndReadIface doc_str mod hi_boot_file - = do { traceIf (sep [hsep [ptext SLIT("Reading"), + = do { traceIf (sep [hsep [ptext (sLit "Reading"), if hi_boot_file - then ptext SLIT("[boot]") + then ptext (sLit "[boot]") else empty, - ptext SLIT("interface for"), + ptext (sLit "interface for"), ppr mod <> semi], - nest 4 (ptext SLIT("reason:") <+> doc_str)]) + nest 4 (ptext (sLit "reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface ; dflags <- getDOpts ; if mod == gHC_PRIM - then returnM (Succeeded (ghcPrimIface, + then return (Succeeded (ghcPrimIface, "")) else do -- Look for the file ; hsc_env <- getTopEnv - ; mb_found <- ioToIOEnv (findExactModule hsc_env mod) + ; mb_found <- liftIO (findExactModule hsc_env mod) ; case mb_found of { - err | notFound err -> do - { traceIf (ptext SLIT("...not found")) - ; dflags <- getDOpts - ; returnM (Failed (cannotFindInterface dflags - (moduleName mod) err)) } ; Found loc mod -> do -- Found file, so read it @@ -451,23 +483,27 @@ findAndReadIface doc_str mod hi_boot_file ; if thisPackage dflags == modulePackageId mod && not (isOneShot (ghcMode dflags)) - then returnM (Failed (homeModError mod loc)) + then return (Failed (homeModError mod loc)) else do { - ; traceIf (ptext SLIT("readIFace") <+> text file_path) + ; 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)) + Failed err -> return (Failed (badIfaceFile file_path err)) Succeeded iface | mi_module iface /= mod -> return (Failed (wrongIfaceModErr iface mod file_path)) | otherwise -> - returnM (Succeeded (iface, file_path)) + return (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... - }}}} - -notFound (Found _ _) = False -notFound _ = True + }} + ; err -> do + { traceIf (ptext (sLit "...not found")) + ; dflags <- getDOpts + ; return (Failed (cannotFindInterface dflags + (moduleName mod) err)) } + } + } \end{code} @readIface@ tries just the one file. @@ -478,9 +514,9 @@ readIface :: Module -> FilePath -> IsBootInterface -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed -readIface wanted_mod file_path is_hi_boot_file - = do { dflags <- getDOpts - ; res <- tryMostM $ readBinIface file_path +readIface wanted_mod file_path _ + = do { res <- tryMostM $ + readBinIface CheckHiWay QuietBinIFaceReading file_path ; case res of Right iface | wanted_mod == actual_mod -> return (Succeeded iface) @@ -575,10 +611,10 @@ ifaceStats eps -- | Read binary interface, and print it out showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do - -- skip the version check; we don't want to worry about profiled vs. + -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. - writeIORef v_IgnoreHiWay True - iface <- initTcRnIf 's' hsc_env () () $ readBinIface filename + iface <- initTcRnIf 's' hsc_env () () $ + readBinIface IgnoreHiWay TraceBinIFaceReading filename printDump (pprModIface iface) \end{code} @@ -586,14 +622,17 @@ showIface hsc_env filename = do 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 - <+> (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) + = vcat [ ptext (sLit "interface") + <+> 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)) @@ -603,17 +642,11 @@ pprModIface 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]") + 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: @@ -624,7 +657,7 @@ When printing export lists, we print like this: \begin{code} pprExport :: IfaceExport -> SDoc pprExport (mod, items) - = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ] + = hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ] where pp_avail :: GenAvailInfo OccName -> SDoc pp_avail (Avail occ) = ppr occ @@ -637,41 +670,37 @@ 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, 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("family instance modules:") <+> fsep (map ppr 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 "family instance modules:") <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot 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 -pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes +pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes where pprFix (occ,fix) = ppr fix <+> ppr occ @@ -681,16 +710,20 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars , 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) + [ 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) - 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 \end{code} @@ -701,8 +734,9 @@ pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec pr %********************************************************* \begin{code} +badIfaceFile :: String -> SDoc -> SDoc badIfaceFile file err - = vcat [ptext SLIT("Bad interface file:") <+> text file, + = vcat [ptext (sLit "Bad interface file:") <+> text file, nest 4 err] hiModuleNameMismatchWarn :: Module -> Module -> Message @@ -710,28 +744,30 @@ hiModuleNameMismatchWarn requested_mod read_mod = withPprStyle defaultUserStyle $ -- we want the Modules below to be qualified with package names, -- so reset the PrintUnqualified setting. - hsep [ ptext SLIT("Something is amiss; requested module ") + hsep [ ptext (sLit "Something is amiss; requested module ") , ppr requested_mod - , ptext SLIT("differs from name found in the interface file") + , ptext (sLit "differs from name found in the interface file") , ppr read_mod ] +wrongIfaceModErr :: ModIface -> Module -> String -> SDoc 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"), + = 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") + ptext (sLit "has an incompatible module name") ] ] where iface_file = doubleQuotes (text file_path) +homeModError :: Module -> ModLocation -> SDoc homeModError mod location - = ptext SLIT("attempting to use module ") <> quotes (ppr mod) + = 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") + <+> ptext (sLit "which is not loaded") \end{code}