X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=5df77fcf88905b26ba07d6358ed9d515141004de;hp=8625a1aa84bed00a884b49315e95601bca2e9c22;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=e68a891932d615590d9b1ab5752ada8142db5053 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 8625a1a..5df77fc 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -6,6 +6,13 @@ 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, @@ -19,7 +26,7 @@ module LoadIface ( #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst ) + tcIfaceFamInst, tcIfaceVectInfo ) import DynFlags import IfaceSyn @@ -45,7 +52,7 @@ import SrcLoc import Maybes import ErrUtils import Finder -import UniqFM +import LazyUniqFM import StaticFlags import Outputable import BinIface @@ -76,7 +83,7 @@ loadSrcInterface doc mod want_boot = do -- 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 Nothing case res of Found _ mod -> do mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) @@ -92,12 +99,12 @@ 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 @@ -118,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 ) @@ -134,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.) + + %********************************************************* %* * @@ -171,13 +200,13 @@ 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 + other -> do { - { let { hi_boot_file = case from of + let { hi_boot_file = case from of ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot @@ -199,7 +228,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: @@ -207,7 +236,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 -> @@ -224,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 @@ -237,13 +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_fam_insts = panic "No mi_fam_insts in PIT", mi_rules = panic "No mi_rules in PIT" - } } + } + } ; updateEps_ $ \ eps -> eps { @@ -255,6 +287,8 @@ 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 = @@ -266,15 +300,16 @@ 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 mod = hang (ptext SLIT("Interface file inconsistency:")) - 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned is needed,"), - ptext SLIT("but is not among the dependencies of interfaces directly imported by the module being compiled")]) + 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 @@ -309,9 +344,9 @@ loadDecl :: Bool -- Don't load pragmas into the decl pool 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) - ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl) + main_name <- lookupOrig mod (ifName decl) +-- ; traceIf (text "Loading decl for " <> ppr main_name) + ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -323,29 +358,73 @@ 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] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- 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 - -- mk_new_bndr allocates in the name cache the final canonical - -- name for the thing, with the correct - -- * parent - -- * location - -- imported name, to fix the module correctly in the cache - mk_new_bndr mod occ - = newGlobalBinder mod occ - (importedSrcLoc (showSDoc (ppr (moduleName mod)))) - -- ToDo: qualify with the package name if necessary - doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used @@ -386,45 +465,44 @@ findAndReadIface doc_str mod hi_boot_file -- 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 (findHiFile hsc_env mod hi_boot_file) + ; mb_found <- liftIO (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 + ; return (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 return (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)) + 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... - }}} - -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. @@ -470,6 +548,7 @@ initExternalPackageState -- 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 } @@ -547,7 +626,8 @@ pprModIface iface <+> 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 + <+> (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) @@ -557,8 +637,9 @@ pprModIface 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 @@ -629,6 +710,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) @@ -669,5 +761,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}