\begin{code}
module LoadIface (
- loadHomeInterface, loadInterface, loadSysInterface,
- loadSrcInterface, loadOrphanModules,
- readIface, -- Used when reading the module's old interface
- predInstGates, ifaceInstGates, ifaceStats,
+ loadInterface, loadHomeInterface, loadWiredInHomeIface,
+ loadSrcInterface, loadSysInterface, loadOrphanModules,
+ findAndReadIface, readIface, -- Used when reading the module's old interface
+ loadDecls, ifaceStats, discardDeclPrags,
initExternalPackageState
) where
#include "HsVersions.h"
-import DriverState ( v_GhcMode, isCompManagerMode )
-import DriverUtil ( replaceFilenameSuffix )
-import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ),
- opt_InPackage )
-import Parser ( parseIface )
-
-import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..),
- IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
- IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
-import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
-import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
- ExternalPackageState(..), emptyTypeEnv, emptyPool,
- lookupIfaceByModName, emptyPackageIfaceTable,
+import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst )
+
+import Packages ( PackageState(..), PackageIdH(..), isHomePackage )
+import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ),
+ isOneShot )
+import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
+ IfaceConDecls(..), IfaceIdInfo(..) )
+import IfaceEnv ( newGlobalBinder )
+import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..),
+ addEpsInStats, ExternalPackageState(..),
+ PackageTypeEnv, emptyTypeEnv, HscEnv(..),
+ lookupIfaceByModule, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
- Pool(..), DeclPool, InstPool,
- RulePool, addRuleToPool, RulePoolContents
+ implicitTyThings
)
-import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
-import TcType ( Type, tcSplitTyConApp_maybe )
-import Type ( funTyCon )
+import BasicTypes ( Version, Fixity(..), FixityDirection(..),
+ isMarkedStrict )
import TcRnMonad
-import PrelNames ( gHC_PRIM_Name )
+import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
import PrelRules ( builtinRules )
-import Rules ( emptyRuleBase )
-import InstEnv ( emptyInstEnv )
+import Rules ( extendRuleBaseList, mkRuleBase )
+import InstEnv ( emptyInstEnv, extendInstEnvList )
import Name ( Name {-instance NamedThing-}, getOccName,
- nameModuleName, isInternalName )
+ nameModule, nameIsLocalOrFrom, isWiredInName )
import NameEnv
import MkId ( seqId )
-import Packages ( basePackage )
-import Module ( Module, ModuleName, ModLocation(ml_hi_file),
- moduleName, isHomeModule, moduleEnvElts,
- extendModuleEnv, lookupModuleEnvByName, moduleUserString
+import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv,
+ addBootSuffix_maybe,
+ extendModuleEnv, lookupModuleEnv, moduleString
)
-import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc,
- mkDataConWrapperOcc, mkDataConWorkerOcc )
-import Class ( Class, className )
-import TyCon ( DataConDetails(..), tyConName )
-import SrcLoc ( mkSrcLoc, importedSrcLoc )
-import Maybes ( isJust, mapCatMaybes )
-import StringBuffer ( hGetStringBuffer )
+import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
+import SrcLoc ( importedSrcLoc )
+import Maybes ( MaybeErr(..) )
import FastString ( mkFastString )
import ErrUtils ( Message )
-import Finder ( findModule, findPackageModule,
- hiBootExt, hiBootVerExt )
-import Lexer
+import Finder ( findModule, findPackageModule, FindResult(..), cantFindError )
import Outputable
import BinIface ( readBinIface )
-import Panic
-
-import DATA_IOREF ( readIORef )
-
-import Directory
+import Panic ( ghcError, tryMost, showException, GhcException(..) )
+import List ( nub )
\end{code}
%************************************************************************
%* *
- loadSrcInterface, loadOrphanModules
+ loadSrcInterface, loadOrphanModules, loadHomeInterface
- These two are called from TcM-land
+ These three are called from TcM-land
%* *
%************************************************************************
\begin{code}
-loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface
+loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface
-- This is called for each 'import' declaration in the source code
--- On a failure, fail in the mnad with an error message
+-- On a failure, fail in the monad with an error message
-loadSrcInterface doc mod_name want_boot
- = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
- (ImportByUser want_boot)
+loadSrcInterface doc mod want_boot
+ = do { mb_iface <- initIfaceTcRn $
+ loadInterface doc mod (ImportByUser want_boot)
; case mb_iface of
- Left err -> failWithTc (elaborate err)
- Right iface -> return iface
+ Failed err -> failWithTc (elaborate err)
+ Succeeded iface -> return iface
}
where
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
- quotes (ppr mod_name) <> colon) 4 err
+ quotes (ppr mod) <> colon) 4 err
-loadOrphanModules :: [ModuleName] -> TcM ()
+---------------
+loadOrphanModules :: [Module] -> TcM ()
loadOrphanModules mods
| null mods = returnM ()
| otherwise = initIfaceTcRn $
where
load mod = loadSysInterface (mk_doc mod) mod
mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
-\end{code}
-
-%*********************************************************
-%* *
- loadHomeInterface
- Called from Iface-land
-%* *
-%*********************************************************
-\begin{code}
-loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface
+---------------
+loadHomeInterface :: SDoc -> Name -> TcRn ModIface
loadHomeInterface doc name
- = ASSERT2( not (isInternalName name), ppr name <+> parens doc )
- loadSysInterface doc (nameModuleName 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)
+ }
+
+---------------
+loadWiredInHomeIface :: Name -> IfM lcl ()
+-- A 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
+loadWiredInHomeIface name
+ = ASSERT( isWiredInName name )
+ do { loadSysInterface doc (nameModule name); return () }
+ where
+ doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name
-loadSysInterface :: SDoc -> ModuleName -> IfM lcl ModIface
+---------------
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
-- A wrapper for loadInterface that Throws an exception if it fails
loadSysInterface doc mod_name
= do { mb_iface <- loadInterface doc mod_name ImportBySystem
; case mb_iface of
- Left err -> ghcError (ProgramError (showSDoc err))
- Right iface -> return iface }
+ Failed err -> ghcError (ProgramError (showSDoc err))
+ Succeeded iface -> return iface }
\end{code}
%*********************************************************
\begin{code}
-loadInterface :: SDoc -> ModuleName -> WhereFrom
- -> IfM lcl (Either Message ModIface)
+loadInterface :: SDoc -> Module -> WhereFrom
+ -> IfM lcl (MaybeErr Message ModIface)
+
-- If it can't find a suitable interface file, we
-- a) modify the PackageIfaceTable to have an empty entry
-- (to avoid repeated complaints)
--
-- It's not necessarily an error for there not to be an interface
-- file -- perhaps the module has changed, and that interface
--- is no longer used -- but the caller can deal with that by
--- catching the exception
+-- is no longer used
-loadInterface doc_str mod_name from
+loadInterface doc_str mod from
= do { -- Read the state
- env <- getTopEnv
- ; let { hpt = hsc_HPT env
- ; eps_var = hsc_EPS env }
- ; eps <- readMutVar eps_var
- ; let { pit = eps_PIT eps }
+ (eps,hpt) <- getEpsAndHpt
+
+ ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
-- Check whether we have the interface already
- ; case lookupIfaceByModName hpt pit mod_name of {
+ ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
Just iface
- -> returnM (Right iface) ; -- Already loaded
+ -> returnM (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
- { if_gbl_env <- getGblEnv
- ; let { hi_boot_file = case from of
+ { let { hi_boot_file = case from of
ImportByUser usr_boot -> usr_boot
ImportBySystem -> sys_boot
- ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name
+ ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod
; sys_boot = case mb_dep of
Just (_, is_boot) -> is_boot
Nothing -> False
} -- based on the dependencies in directly-imported modules
-- READ THE MODULE IN
- ; read_result <- findAndReadIface doc_str mod_name hi_boot_file
+ ; let explicit | ImportByUser _ <- from = True
+ | otherwise = False
+ ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file
+ ; dflags <- getDOpts
; case read_result of {
- Left err -> do
- { let { -- Not found, so add an empty iface to
+ Failed err -> do
+ { let fake_iface = emptyModIface HomePackage mod
+
+ ; updateEps_ $ \eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+ -- Not found, so add an empty iface to
-- the EPS map so that we don't look again
- fake_iface = emptyModIface opt_InPackage mod_name
- ; new_pit = extendModuleEnv pit (mi_module fake_iface) fake_iface
- ; new_eps = eps { eps_PIT = new_pit } }
- ; writeMutVar eps_var new_eps
- ; returnM (Left err) } ;
+
+ ; returnM (Failed err) } ;
-- Found and parsed!
- Right iface ->
+ Succeeded (iface, file_path) -- Sanity check:
+ | ImportBySystem <- from, -- system-importing...
+ isHomePackage (mi_package iface), -- ...a home-package module
+ Nothing <- mb_dep -- ...that we know nothing about
+ -> returnM (Failed (badDepMsg mod))
- let { mod = mi_module iface } in
+ | otherwise ->
- -- Sanity check. If we're system-importing a module we know nothing at all
- -- about, it should be from a different package to this one
- WARN( case from of { ImportBySystem -> True; other -> False } &&
- not (isJust mb_dep) &&
- isHomeModule mod,
- ppr mod $$ ppr mb_dep)
+ let
+ loc_doc = text file_path
+ in
+ initIfaceLcl mod loc_doc $ do
- initIfaceLcl (moduleName mod) $ do
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
-- (which only happens in OneShot mode; in Batch/Interactive
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- { new_eps_decls <- loadDecls mod (eps_decls eps) (mi_decls iface)
- ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface)
- ; new_eps_rules <- loadRules mod (eps_rules eps) (mi_rules iface)
+ ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
+ ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
+ ; new_eps_rules <- if ignore_prags
+ then return []
+ else mapM tcIfaceRule (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" }
+ mi_rules = panic "No mi_rules in PIT" } }
+
+ ; updateEps_ $ \ eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
+ eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules,
+ eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts,
+ eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
+ (length new_eps_insts) (length new_eps_rules) }
- ; new_eps = eps { eps_PIT = extendModuleEnv pit mod final_iface,
- eps_decls = new_eps_decls,
- eps_rules = new_eps_rules,
- eps_insts = new_eps_insts } }
- ; writeMutVar eps_var new_eps
- ; return (Right final_iface)
- }}}}}
+ ; 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,"),
+ ptext SLIT("but does not appear in the dependencies of the interface")])
-----------------------------------------------------
-- Loading type/class/value decls
-- the declaration itself, will find the fully-glorious Name
-----------------------------------------------------
-loadDecls :: Module -> DeclPool
+addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
+addDeclsToPTE pte things = extendNameEnvList pte things
+
+loadDecls :: Bool
-> [(Version, IfaceDecl)]
- -> IfM lcl DeclPool
-loadDecls mod (Pool decls_map n_in n_out) decls
- = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls
- ; returnM (Pool decls_map' (n_in + length decls) n_out) }
-
-loadDecl ignore_prags mod decls_map (_version, decl)
- = do { main_name <- mk_new_bndr Nothing (ifName decl)
- ; let decl' | ignore_prags = zapIdInfo decl
- | otherwise = decl
-
- -- Populate the name cache with final versions of all the subordinate names
- ; mapM_ (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl')
-
- -- Extend the decls pool with a mapping for the main name (only)
- ; returnM (extendNameEnv decls_map main_name decl') }
+ -> IfL [(Name,TyThing)]
+loadDecls ignore_prags ver_decls
+ = do { mod <- getIfModule
+ ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
+ ; return (concat thingss)
+ }
+
+loadDecl :: Bool -- Don't load pragmas into the decl pool
+ -> Module
+ -> (Version, IfaceDecl)
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
+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 Nothing (ifName decl)
+ ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
+
+ -- Typecheck the thing, lazily
+ -- NB. firstly, the laziness is there in case we never need the
+ -- declaration (in one-shot mode), and secondly it is there so that
+ -- we don't look up the occurrence of a name before calling mk_new_bndr
+ -- on the binder. This is important because we must get the right name
+ -- which includes its nameParent.
+ ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
+ ; 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)
+
+ ; returnM ((main_name, thing) : [(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
+ stripped_decl | ignore_prags = discardDeclPrags decl
+ | otherwise = decl
+
-- mk_new_bndr allocates in the name cache the final canonical
-- name for the thing, with the correct
- -- * package info
-- * parent
-- * location
-- imported name, to fix the module correctly in the cache
- mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
- loc = importedSrcLoc (moduleUserString mod)
+ mk_new_bndr mod mb_parent occ
+ = newGlobalBinder mod occ mb_parent
+ (importedSrcLoc (moduleString mod))
+
+ doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
-zapIdInfo decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = DiscardedInfo }
-zapIdInfo decl = decl
- -- Don't alter "NoInfo", just "HasInfo"
+discardDeclPrags :: IfaceDecl -> IfaceDecl
+discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
+discardDeclPrags decl = decl
+
+bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
+bumpDeclStats name
+ = do { traceIf (text "Loading decl for" <+> ppr name)
+ ; updateEps_ (\eps -> let stats = eps_stats eps
+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+ }
-----------------
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
--- *Excludes* the 'main' name, but *includes* the implicitly-bound names
--- Rather revolting, because it has to predict what gets bound
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- Deeply revolting, because it has to predict what gets bound,
+-- especially the question of whether there's a wrapper for a datacon
ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
- = [tc_occ, dc_occ] ++
+ = [tc_occ, dc_occ, dcww_occ] ++
[op | IfaceClassOp op _ _ <- sigs] ++
- [mkSuperDictSelOcc n cls_occ | n <- [1..length sc_ctxt]] ++
- -- The worker and wrapper for the DataCon of the class TyCon
- -- are based off the data-con name
- [mkDataConWrapperOcc dc_occ, mkDataConWorkerOcc dc_occ]
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
tc_occ = mkClassTyConOcc cls_occ
dc_occ = mkClassDataConOcc cls_occ
-
-ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = []
-ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons})
- = foldr ((++) . conDeclBndrs) [] cons
-
-ifaceDeclSubBndrs other = []
-
-conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
- = fields ++
- [con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
-
-
------------------------------------------------------
--- Loading instance decls
------------------------------------------------------
-
-loadInsts :: Module -> InstPool -> [IfaceInst] -> IfL InstPool
-loadInsts mod (Pool pool n_in n_out) decls
- = do { new_pool <- foldlM (loadInstDecl (moduleName mod)) pool decls
- ; returnM (Pool new_pool
- (n_in + length decls)
- n_out) }
-
-loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty})
- = do {
- -- Find out what type constructors and classes are "gates" for the
- -- instance declaration. If all these "gates" are slurped in then
- -- we should slurp the instance decl too.
- --
- -- We *don't* want to count names in the context part as gates, though.
- -- For example:
- -- instance Foo a => Baz (T a) where ...
- --
- -- Here the gates are Baz and T, but *not* Foo.
- --
- -- HOWEVER: functional dependencies make things more complicated
- -- class C a b | a->b where ...
- -- instance C Foo Baz where ...
- -- Here, the gates are really only C and Foo, *not* Baz.
- -- That is, if C and Foo are visible, even if Baz isn't, we must
- -- slurp the decl.
- --
- -- Rather than take fundeps into account "properly", we just slurp
- -- if C is visible and *any one* of the Names in the types
- -- This is a slightly brutal approximation, but most instance decls
- -- are regular H98 ones and it's perfect for them.
- --
- -- NOTICE that we rename the type before extracting its free
- -- variables. The free-variable finder for a renamed HsType
- -- does the Right Thing for built-in syntax like [] and (,).
- let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
- ; cls <- lookupIfaceExt cls_ext
- ; tcs <- mapM lookupIfaceTc tc_exts
- ; let { new_pool = extendNameEnv_C combine pool cls [(tcs, (mod,decl))]
- ; combine old _ = (tcs,(mod,decl)) : old }
- ; returnM new_pool
- }
-
------------------------------------------------------
--- Loading Rules
------------------------------------------------------
-
-loadRules :: Module -> RulePool -> [IfaceRule] -> IfL RulePool
-loadRules mod pool@(Pool rule_pool n_in n_out) rules
- = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; if ignore_prags then
- returnM pool
- else do
- { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
- ; returnM (Pool new_pool (n_in + length rules) n_out) } }
-
-loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents
--- "Gate" the rule simply by a crude notion of the free vars of
--- the LHS. It can be crude, because having too few free vars is safe.
-loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
- = do { names <- mapM lookupIfaceExt (fn : arg_fvs)
- ; returnM (addRuleToPool pool (mod_name, decl) names) }
+ dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
+ | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
+ = []
+-- Newtype
+ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ,
+ ifConFields = fields})})
+ = fields ++ [con_occ, mkDataConWrapperOcc con_occ]
+ -- Wrapper, no worker; see MkId.mkDataConIds
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ = nub (concatMap fld_occs cons) -- Eliminate duplicate fields
+ ++ concatMap dc_occs cons
where
- arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg]
-
----------------------------
-crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName]
--- A crude approximation to the free external names of an IfExpr
--- Returns a subset of the true answer
-crudeIfExprGblFvs (IfaceType ty) = get_tcs ty
-crudeIfExprGblFvs (IfaceExt v) = [v]
-crudeIfExprGblFvs other = [] -- Well, I said it was crude
-
-get_tcs :: IfaceType -> [IfaceExtName]
--- Get a crude subset of the TyCons of an IfaceType
-get_tcs (IfaceTyVar _) = []
-get_tcs (IfaceAppTy t1 t2) = get_tcs t1 ++ get_tcs t2
-get_tcs (IfaceFunTy t1 t2) = get_tcs t1 ++ get_tcs t2
-get_tcs (IfaceForAllTy _ t) = get_tcs t
-get_tcs (IfacePredTy st) = case st of
- IfaceClassP cl ts -> get_tcs_s ts
- IfaceIParam _ t -> get_tcs t
-get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts
-get_tcs (IfaceTyConApp other ts) = get_tcs_s ts
-
--- The lists are always small => appending is fine
-get_tcs_s :: [IfaceType] -> [IfaceExtName]
-get_tcs_s tys = foldr ((++) . get_tcs) [] tys
-\end{code}
-
+ fld_occs (IfVanillaCon { ifConFields = fields }) = fields
+ fld_occs (IfGadtCon {}) = []
+ dc_occs con_decl
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl
+ strs = ifConStricts con_decl
+ wrap_occ = mkDataConWrapperOcc con_occ
+ work_occ = mkDataConWorkerOcc con_occ
+ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ -- ToDo: may miss strictness in existential dicts
+
+ifaceDeclSubBndrs _other = []
-%*********************************************************
-%* *
- Gating
-%* *
-%*********************************************************
-
-Extract the gates of an instance declaration
-
-\begin{code}
-ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon])
--- Return the class, and the tycons mentioned in the rest of the head
--- We only pick the TyCon at the root of each type, to avoid
--- difficulties with overlap. For example, suppose there are interfaces
--- in the pool for
--- C Int b
--- C a [b]
--- C a [T]
--- Then, if we are trying to resolve (C Int x), we need the first
--- if we are trying to resolve (C x [y]), we need *both* the latter
--- two, even though T is not involved yet, so that we spot the overlap
-
-ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t
-ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t
-ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys
-ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
- -- The other cases should not happen
-
-instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys)
- where
- root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName)
- root_tycon (IfaceTyConApp tc _) = Just tc
- root_tycon other = Nothing
-
-funTyConExtName = mkIfaceExtName (tyConName funTyCon)
-
-
-predInstGates :: Class -> [Type] -> (Name, [Name])
--- The same function, only this time on the predicate found in a dictionary
-predInstGates cls tys
- = (className cls, mapCatMaybes root_tycon tys)
- where
- root_tycon ty = case tcSplitTyConApp_maybe ty of
- Just (tc, _) -> Just (tyConName tc)
- Nothing -> Nothing
\end{code}
%*********************************************************
\begin{code}
-findAndReadIface :: SDoc -> ModuleName
+findAndReadIface :: Bool -- True <=> explicit user import
+ -> SDoc -> Module
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
- -> IfM lcl (Either Message ModIface)
+ -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-- It *doesn't* add an error to the monad, because
-- sometimes it's ok to fail... see notes with loadInterface
-findAndReadIface doc_str mod_name hi_boot_file
+findAndReadIface explicit doc_str mod_name hi_boot_file
= do { traceIf (sep [hsep [ptext SLIT("Reading"),
if hi_boot_file
then ptext SLIT("[boot]")
nest 4 (ptext SLIT("reason:") <+> doc_str)])
-- Check for GHC.Prim, and return its static interface
- ; if mod_name == gHC_PRIM_Name
- then returnM (Right ghcPrimIface)
+ ; dflags <- getDOpts
+ ; let base_pkg = basePackageId (pkgState dflags)
+ ; if mod_name == gHC_PRIM
+ then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg },
+ "<built in interface for GHC.Prim>"))
else do
-- Look for the file
- ; mb_found <- ioToIOEnv (findHiFile mod_name hi_boot_file)
+ ; hsc_env <- getTopEnv
+ ; mb_found <- ioToIOEnv (findHiFile hsc_env explicit mod_name hi_boot_file)
; case mb_found of {
- Left files -> do
+ Failed err -> do
{ traceIf (ptext SLIT("...not found"))
; dflags <- getDOpts
- ; returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) } ;
+ ; returnM (Failed (cantFindError dflags mod_name err)) } ;
- Right file_path -> do
+ Succeeded (file_path, pkg) -> do
-- Found file, so read it
{ traceIf (ptext SLIT("readIFace") <+> text file_path)
; read_result <- readIface mod_name file_path hi_boot_file
; case read_result of
- Left err -> returnM (Left (badIfaceFile file_path err))
- Right iface -> returnM (Right iface)
+ Failed err -> returnM (Failed (badIfaceFile file_path err))
+ Succeeded iface
+ | mi_module iface /= mod_name ->
+ return (Failed (wrongIfaceModErr iface mod_name file_path))
+ | otherwise ->
+ returnM (Succeeded (iface{mi_package=pkg}, file_path))
+ -- Don't forget to fill in the package name...
}}}
-findHiFile :: ModuleName -> IsBootInterface
- -> IO (Either [FilePath] FilePath)
-findHiFile mod_name hi_boot_file
+findHiFile :: HscEnv -> Bool -> Module -> IsBootInterface
+ -> IO (MaybeErr FindResult (FilePath, PackageIdH))
+findHiFile hsc_env explicit mod_name hi_boot_file
= do {
-- In interactive or --make mode, we are *not allowed* to demand-load
-- a home package .hi file. So don't even look for them.
-- This helps in the case where you are sitting in eg. ghc/lib/std
-- and start up GHCi - it won't complain that all the modules it tries
-- to load are found in the home location.
- ghci_mode <- readIORef v_GhcMode ;
- let { home_allowed = hi_boot_file ||
- not (isCompManagerMode ghci_mode) } ;
+ let { home_allowed = isOneShot (ghcMode (hsc_dflags hsc_env)) } ;
maybe_found <- if home_allowed
- then findModule mod_name
- else findPackageModule mod_name ;
-
- case maybe_found of {
- Left files -> return (Left files) ;
-
- Right (_, loc) -> do { -- Don't need module returned by finder
-
- -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
- let { hi_path = ml_hi_file loc ;
- hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
- hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
- };
-
- if not hi_boot_file then
- return (Right hi_path)
- else do {
- hi_ver_exists <- doesFileExist hi_boot_ver_path ;
- if hi_ver_exists then return (Right hi_boot_ver_path)
- else return (Right hi_boot_path)
- }}}}
+ then findModule hsc_env mod_name explicit
+ else findPackageModule hsc_env mod_name explicit;
+
+ case maybe_found of
+ Found loc pkg -> return (Succeeded (path, pkg))
+ where
+ path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc)
+
+ err -> return (Failed err)
+ }
\end{code}
@readIface@ tries just the one file.
\begin{code}
-readIface :: ModuleName -> String -> IsBootInterface
- -> IfM lcl (Either Message ModIface)
- -- Left err <=> file not found, or unreadable, or illegible
- -- Right iface <=> successfully found and parsed
+readIface :: Module -> String -> IsBootInterface
+ -> TcRnIf gbl lcl (MaybeErr Message ModIface)
+ -- Failed err <=> file not found, or unreadable, or illegible
+ -- Succeeded iface <=> successfully found and parsed
-readIface wanted_mod_name file_path is_hi_boot_file
+readIface wanted_mod file_path is_hi_boot_file
= do { dflags <- getDOpts
- ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) }
-
-read_iface dflags wanted_mod file_path is_hi_boot_file
- | is_hi_boot_file -- Read ascii
- = do { res <- tryMost (hGetStringBuffer file_path) ;
- case res of {
- Left exn -> return (Left (text (showException exn))) ;
- Right buffer ->
- case unP parseIface (mkPState buffer loc dflags) of
- PFailed loc1 loc2 err -> return (Left (showPFailed loc1 loc2 err))
- POk _ iface
- | wanted_mod == actual_mod -> return (Right iface)
- | otherwise -> return (Left err)
- where
- actual_mod = moduleName (mi_module iface)
- err = hiModuleNameMismatchWarn wanted_mod actual_mod
- }}
-
- | otherwise -- Read binary
- = do { res <- tryMost (readBinIface file_path)
+ ; ioToIOEnv $ do
+ { res <- tryMost (readBinIface file_path)
; case res of
- Right iface -> return (Right iface)
- Left exn -> return (Left (text (showException exn))) }
- where
- loc = mkSrcLoc (mkFastString file_path) 1 0
+ Right iface
+ | wanted_mod == actual_mod -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
+ where
+ actual_mod = mi_module iface
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
+
+ Left exn -> return (Failed (text (showException exn)))
+ }}
\end{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
+ eps_is_boot = emptyModuleEnv,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
- eps_rule_base = emptyRuleBase,
- eps_decls = emptyPool emptyNameEnv,
- eps_insts = emptyPool emptyNameEnv,
- eps_rules = foldr add (emptyPool []) builtinRules
- }
- where
+ eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
- add (fn_name, core_rule) (Pool rules n_in n_out)
- = Pool rules' (n_in+1) n_out
- where
- rules' = addRuleToPool rules iface_rule [fn_name]
- iface_rule = (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)
+ 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 }
+ }
\end{code}
\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
- = (emptyModIface basePackage gHC_PRIM_Name) {
- mi_exports = [(gHC_PRIM_Name, ghcPrimExports)],
+ = (emptyModIface HomePackage gHC_PRIM) {
+ mi_exports = [(gHC_PRIM, ghcPrimExports)],
mi_decls = [],
mi_fixities = fixities,
mi_fix_fn = mkIfaceFixCache fixities
\begin{code}
ifaceStats :: ExternalPackageState -> SDoc
ifaceStats eps
- = hcat [text "Renamer stats: ", stats]
+ = hcat [text "Renamer stats: ", msg]
where
- n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
- -- This is really only right for a one-shot compile
-
- Pool _ n_decls_in n_decls_out = eps_decls eps
- Pool _ n_insts_in n_insts_out = eps_insts eps
- Pool _ n_rules_in n_rules_out = eps_rules eps
-
- stats = vcat
- [int n_mods <+> text "interfaces read",
- hsep [ int n_decls_out, text "type/class/variable imported, out of",
- int n_decls_in, text "read"],
- hsep [ int n_insts_out, text "instance decls imported, out of",
- int n_insts_in, text "read"],
- hsep [ int n_rules_out, text "rule decls imported, out of",
- int n_rules_in, text "read"]
+ stats = eps_stats eps
+ msg = vcat
+ [int (n_ifaces_in stats) <+> text "interfaces read",
+ hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+ int (n_decls_in stats), text "read"],
+ hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+ int (n_insts_in stats), text "read"],
+ hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+ int (n_rules_in stats), text "read"]
]
\end{code}
= vcat [ptext SLIT("Bad interface file:") <+> text file,
nest 4 err]
-hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message
+hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn requested_mod read_mod =
hsep [ ptext SLIT("Something is amiss; requested module name")
, ppr requested_mod
, ppr read_mod
]
-noIfaceErr dflags mod_name boot_file files
- = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
- $$ extra
- where
- extra
- | verbosity dflags < 3 =
- text "(use -v to see a list of the files searched for)"
- | otherwise =
- hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
+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"),
+ nest 2 iface_file,
+ ptext SLIT("has an incompatible module name")
+ ]
+ ]
+ where iface_file = doubleQuotes (text file_path)
\end{code}
projects / ghc-hetmet.git / blobdiff