diff options
Diffstat (limited to 'compiler/iface/LoadIface.hs')
| -rw-r--r-- | compiler/iface/LoadIface.hs | 133 |
1 files changed, 117 insertions, 16 deletions
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index c5c3538284..4e1fea068e 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -24,7 +24,9 @@ module LoadIface ( findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, + moduleFreeHolesPrecise, + pprModIfaceSimple, ifaceStats, pprModIface, showIface ) where @@ -69,6 +71,8 @@ import FastString import Fingerprint import Hooks import FieldLabel +import RnModIface +import UniqDSet import Control.Monad import Data.IORef @@ -352,11 +356,7 @@ loadPluginInterface doc mod_name -- | 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 - ; dflags <- getDynFlags - ; case mb_iface of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded iface -> return iface } + = withException (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom @@ -375,6 +375,12 @@ loadInterface :: SDoc -> Module -> WhereFrom -- is no longer used loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do dflags <- getDynFlags + -- Redo search for our local hole module + loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from + | otherwise = do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv @@ -402,7 +408,7 @@ loadInterface doc_str mod from WARN( hi_boot_file && fmap fst (if_rec_types gbl_env) == Just mod, ppr mod ) - findAndReadIface doc_str mod hi_boot_file + computeInterface doc_str hi_boot_file mod ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -423,12 +429,11 @@ loadInterface doc_str mod from -- 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) -> - + Succeeded (iface, loc) -> let - loc_doc = text file_path + loc_doc = text loc in - initIfaceLcl mod loc_doc (mi_boot iface) $ do + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface @@ -464,7 +469,8 @@ loadInterface doc_str mod from } ; updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) then eps else + if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + then eps else eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, @@ -495,6 +501,91 @@ loadInterface doc_str mod from ; return (Succeeded final_iface) }}}} +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: DynFlags -> ModIface -> Bool +is_external_sig dflags iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + moduleUnitId (mi_module iface) /= thisPackage dflags + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=<B>]:M@ but we only +-- have an interface for @p[A=<A>]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface :: + SDoc -> IsBootInterface -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) +computeInterface doc_str hi_boot_file mod0 = do + MASSERT( not (isHoleModule mod0) ) + dflags <- getDynFlags + case splitModuleInsts mod0 of + (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do + r <- findAndReadIface doc_str imod hi_boot_file + case r of + Succeeded (iface0, path) -> do + hsc_env <- getTopEnv + r <- liftIO (rnModIface hsc_env insts Nothing iface0) + return (Succeeded (r, path)) + Failed err -> return (Failed err) + (mod, _) -> + findAndReadIface doc_str mod hi_boot_file + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=<A>,B=<B>]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case splitModuleInsts mod of + (imod, Just insts) -> do + traceIf (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHpt + dflags <- getDynFlags + case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt dflags eps hpt = + fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod False + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot @@ -678,7 +769,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings. See Trac #8320. -} -findAndReadIface :: SDoc -> Module +findAndReadIface :: SDoc -> VirginModule -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) @@ -687,7 +778,6 @@ findAndReadIface :: SDoc -> Module -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface - findAndReadIface doc_str mod hi_boot_file = do traceIf (sep [hsep [text "Reading", if hi_boot_file @@ -710,7 +800,6 @@ findAndReadIface doc_str mod hi_boot_file mb_found <- liftIO (findExactModule hsc_env mod) case mb_found of Found loc mod -> do - -- Found file, so read it let file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) @@ -740,7 +829,11 @@ findAndReadIface doc_str mod hi_boot_file -- Don't forget to fill in the package name... checkBuildDynamicToo (Succeeded (iface, filePath)) = do dflags <- getDynFlags - whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + -- Indefinite interfaces are ALWAYS non-dynamic, and + -- that's OK. + let is_definite_iface = moduleIsDefinite (mi_module iface) + when is_definite_iface $ + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do let ref = canGenerateDynamicToo dflags dynFilePath = addBootSuffix_maybe hi_boot_file $ replaceExtension filePath (dynHiSuf dflags) @@ -759,7 +852,7 @@ findAndReadIface doc_str mod hi_boot_file -- @readIface@ tries just the one file. -readIface :: Module -> FilePath +readIface :: VirginModule -> FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -791,6 +884,7 @@ initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, + eps_free_holes = emptyModuleEnv, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, @@ -868,6 +962,11 @@ showIface hsc_env filename = do let dflags = hsc_dflags hsc_env log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface) +-- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: ModIface -> SDoc +pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) + pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface @@ -935,6 +1034,8 @@ pprUsage usage@UsageHomeModule{} pprUsage usage@UsageFile{} = hsep [text "addDependentFile", doubleQuotes (text (usg_file_path usage))] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' |