loadInterface, loadInterfaceForName, loadWiredInHomeIface,
loadSrcInterface, loadSysInterface, loadOrphanModules,
findAndReadIface, readIface, -- Used when reading the module's old interface
- loadDecls, ifaceStats, discardDeclPrags,
+ loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
- pprModIface, showIface -- Print the iface in Foo.hi
+ ifaceStats, pprModIface, showIface -- Print the iface in Foo.hi
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst )
+import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst )
import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
- IfaceConDecls(..), IfaceFamInst(..),
- IfaceIdInfo(..) )
+ IfaceConDecls(..), IfaceFamInst(..) )
import IfaceEnv ( newGlobalBinder, lookupIfaceTc )
import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
Deprecs(..), Dependencies(..),
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr Message ModIface)
+-- loadInterface looks in both the HPT and PIT for the required interface
+-- If not found, it loads it, and puts it in the PIT (always).
+
-- If it can't find a suitable interface file, we
-- a) modify the PackageIfaceTable to have an empty entry
-- (to avoid repeated complaints)
; 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)
+ ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
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")])
+ 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")])
-----------------------------------------------------
-- Loading type/class/value decls
(ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
- -- NB. firstly, the laziness is there in case we never need the
+ -- 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)
+
+ ; thing <- forkM doc $ do { bumpDeclStats main_name
+ ; tcIfaceDecl ignore_prags decl }
+
+ -- Populate the type environment with the implicitTyThings too
; 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 (stripped_decl))
+ pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names]
}
-- 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
-- * parent
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
-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)
\begin{code}
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal,
+ tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal,
tcExtCoreBindings
) where
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadInterface, loadWiredInHomeIface,
- loadDecls, findAndReadIface )
+import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls )
import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc,
import NameEnv
import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace,
pprNameSpace, occNameFS )
-import FastString ( FastString )
import Module ( Module, moduleName )
import UniqFM ( lookupUFM )
import UniqSupply ( initUs_, uniqsFromSupply )
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual )
import DynFlags ( DynFlag(..), isOneShot )
+import Control.Monad ( unless )
import List ( elemIndex)
import Maybe ( catMaybes )
= return ()
| otherwise
= do { mod <- getModule
- ; if nameIsLocalOrFrom mod tc_name then
+ ; unless (mod == nameModule tc_name)
+ (initIfaceTcRn (loadWiredInHomeIface tc_name))
-- Don't look for (non-existent) Float.hi when
-- compiling Float.lhs, which mentions Float of course
- return ()
- else -- A bit yukky to call initIfaceTcRn here
- initIfaceTcRn (loadWiredInHomeIface tc_name)
+ -- A bit yukky to call initIfaceTcRn here
}
where
tc_name = tyConName tc
-- to handle unboxed tuples, so it must not see unfoldings.
ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- -- Load & typecheck the decls
- ; decl_things <- loadDecls ignore_prags (mi_decls iface)
-
- ; let type_env = mkNameEnv decl_things
+ -- Typecheck the decls. This is done lazily, so that the knot-tying
+ -- within this single module work out right. In the If monad there is
+ -- no global envt for the current interface; instead, the knot is tied
+ -- through the if_rec_types field of IfGblEnv
+ ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
+ ; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
-- Now do those rules and instances
- ; let { rules | ignore_prags = []
- | otherwise = mi_rules iface
- ; dfuns = mi_insts iface
- }
- ; dfuns <- mapM tcIfaceInst dfuns
- ; rules <- mapM tcIfaceRule rules
+ ; dfuns <- mapM tcIfaceInst (mi_insts iface)
+ ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
-- Exports
- ; exports <- ifaceExportNames (mi_exports iface)
+ ; exports <- ifaceExportNames (mi_exports iface)
-- Finished
+ ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
+ text "Type envt:" <+> ppr type_env])
; return $ ModDetails { md_types = type_env
, md_insts = dfuns
, md_fam_insts = mkDetailsFamInstCache type_env
\begin{code}
-tcIfaceDecl :: IfaceDecl -> IfL TyThing
+tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
-tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
+tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
- ; info <- tcIdInfo name ty info
+ ; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkVanillaGlobal name ty info)) }
-tcIfaceDecl (IfaceData {ifName = occ_name,
+tcIfaceDecl ignore_prags
+ (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
; return (ATyCon tycon)
}}
-tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+tcIfaceDecl ignore_prags
+ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
}
-tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
+tcIfaceDecl ignore_prags
+ (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mappM tc_sig rdr_sigs
; fds <- mappM tc_fd rdr_fds
- ; ats' <- mappM tcIfaceDecl rdr_ats
+ ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats
; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
ATyCon (setTyConArgPoss tycon poss)
setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
-tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
+tcIfaceRules :: Bool -- True <=> ignore rules
+ -> [IfaceRule]
+ -> IfL [CoreRule]
+tcIfaceRules ignore_prags if_rules
+ | ignore_prags = return []
+ | otherwise = mapM tcIfaceRule if_rules
+
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
%************************************************************************
\begin{code}
-tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
-tcIdInfo name ty NoInfo = return vanillaIdInfo
-tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
+tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags name ty info
+ | ignore_prags = return vanillaIdInfo
+ | otherwise = case info of
+ NoInfo -> return vanillaIdInfo
+ HasInfo info -> foldlM tcPrag init_info info
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
-- Wired-in things include TyCons, DataCons, and Ids
- = do { loadWiredInHomeIface name; return thing }
- -- Even though we are in an interface file, we want to make
- -- sure its instances are loaded (imagine f :: Double -> Double)
- -- and its RULES are loaded too
+ = do { ifCheckWiredInThing name; return thing }
| otherwise
= do { (eps,hpt) <- getEpsAndHpt
; dflags <- getDOpts
Succeeded thing -> return thing
}}}}}
+ifCheckWiredInThing :: Name -> IfL ()
+-- Even though we are in an interface file, we want to make
+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
+-- Ditto want to ensure that RULES are loaded too
+ifCheckWiredInThing name
+ = do { mod <- getIfModule
+ -- Check whether we are typechecking the interface for this
+ -- very module. E.g when compiling the base library in --make mode
+ -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
+ -- the HPT, so without the test we'll demand-load it into the PIT!
+ -- C.f. the same test in checkWiredInTyCon above
+ ; unless (mod == nameModule name)
+ (loadWiredInHomeIface name) }
+
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon
-- sure the instances and RULES of this tycon are loaded
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
-tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc)
+tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc)
; return tc }
tcIfaceClass :: IfaceExtName -> IfL Class
projects / ghc-hetmet.git / commitdiff