\begin{code}
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal,
- tcExtCoreBindings
+ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+ tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
import IfaceEnv
import BuildTyCl
import TcRnMonad
+import TcType
import Type
+import Coercion
import TypeRep
import HscTypes
+import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
import TyCon
import DataCon
import TysWiredIn
-import Var ( TyVar )
+import TysPrim ( anyTyConOfKind )
+import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
+import VarEnv
import Name
import NameEnv
-import OccName
+import OccurAnal ( occurAnalyseExpr )
+import Demand ( isBottomingSig )
import Module
import UniqFM
import UniqSupply
import ErrUtils
import Maybes
import SrcLoc
-import Util
import DynFlags
-import Breakpoints
-import Control.Monad
+import Util
+import FastString
+import Control.Monad
import Data.List
-import Data.Maybe
\end{code}
This module takes
An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.
- -- For (b) consider: f = $(...h....)
+ -- For (b) consider: f = \$(...h....)
-- where h is imported, and calls f via an hi-boot file.
-- This is bad! But it is not seen as a staging error, because h
-- is indeed imported. We don't want the type-checker to black-hole
-- Entry point for *source-code* uses of importDecl
tcImportDecl name
| Just thing <- wiredInNameTyThing_maybe name
- = do { initIfaceTcRn (loadWiredInHomeIface name)
+ = do { when (needWiredInHomeIface thing)
+ (initIfaceTcRn (loadWiredInHomeIface name))
+ -- See Note [Loading instances for wired-in things]
; return thing }
| otherwise
= do { traceIf (text "tcImportDecl" <+> ppr name)
Succeeded thing -> return thing
Failed err -> failWithTc err }
-checkWiredInTyCon :: TyCon -> TcM ()
--- Ensure that the home module of the TyCon (and hence its instances)
--- are loaded. It might not be a wired-in tycon (see the calls in TcUnify),
--- in which case this is a no-op.
-checkWiredInTyCon tc
- | not (isWiredInName tc_name)
- = return ()
- | otherwise
- = do { mod <- getModule
- ; 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
- -- A bit yukky to call initIfaceTcRn here
- }
- where
- tc_name = tyConName tc
-
importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
do { traceIf nd_doc
-- Load the interface, which should populate the PTE
- ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+ ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+ loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of {
Failed err_msg -> return (Failed err_msg) ;
- Succeeded iface -> do
+ Succeeded _ -> do
-- Now look it up again; this time we should find it
{ eps <- getEps
Nothing -> return (Failed not_found_msg)
}}}
where
- nd_doc = ptext SLIT("Need decl for") <+> ppr name
- not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+>
- pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
- 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
- ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
+ nd_doc = ptext (sLit "Need decl for") <+> ppr name
+ not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
+ pprNameSpace (occNameSpace (nameOccName name)) <+> (ppr (nameOccName name)))
+ 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
+\end{code}
+
+%************************************************************************
+%* *
+ Checks for wired-in things
+%* *
+%************************************************************************
+
+Note [Loading instances for wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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}
+
+* HOWEVER, only do this for TyCons. There are no wired-in Classes. There
+ are some wired-in Ids, but we don't want to load their interfaces. For
+ example, Control.Exception.Base.recSelError is wired in, but that module
+ is compiled late in the base library, and we don't want to force it to
+ load before it's been compiled!
+
+All of this is done by the type checker. The renamer plays no role.
+(It used to, but no longer.)
+
+
+\begin{code}
+checkWiredInTyCon :: TyCon -> TcM ()
+-- Ensure that the home module of the TyCon (and hence its instances)
+-- are loaded. See Note [Loading instances for wired-in things]
+-- It might not be a wired-in tycon (see the calls in TcUnify),
+-- in which case this is a no-op.
+checkWiredInTyCon tc
+ | not (isWiredInName tc_name)
+ = return ()
+ | otherwise
+ = do { mod <- getModule
+ ; ASSERT( isExternalName tc_name )
+ when (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
+ -- A bit yukky to call initIfaceTcRn here
+ }
+ where
+ tc_name = tyConName tc
+
+ifCheckWiredInThing :: TyThing -> 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
+-- See Note [Loading instances for wired-in things]
+ifCheckWiredInThing thing
+ = 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
+ ; let name = getName thing
+ ; ASSERT2( isExternalName name, ppr name )
+ when (needWiredInHomeIface thing && mod /= nameModule name)
+ (loadWiredInHomeIface name) }
+
+needWiredInHomeIface :: TyThing -> Bool
+-- Only for TyCons; see Note [Loading instances for wired-in things]
+needWiredInHomeIface (ATyCon {}) = True
+needWiredInHomeIface _ = False
\end{code}
%************************************************************************
; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
- -- Now do those rules and instances
+ -- Now do those rules, instances and annotations
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
+ ; anns <- tcIfaceAnnotations (mi_anns iface)
+
+ -- Vectorisation information
+ ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env
+ (mi_vect_info iface)
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
+ , md_anns = anns
+ , md_vect_info = vect_info
, md_exports = exports
- , md_dbg_sites = noDbgSites
}
}
\end{code}
%************************************************************************
\begin{code}
-tcHiBootIface :: Module -> TcRn ModDetails
+tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
-tcHiBootIface mod
+tcHiBootIface hsc_src mod
+ | isHsBoot hsc_src -- Already compiling a hs-boot file
+ = return emptyModDetails
+ | otherwise
= do { traceIf (text "loadHiBootInterface" <+> ppr mod)
; mode <- getGhcMode
; case lookupUFM hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (hm_details info)
- other -> return emptyModDetails }
+ _ -> return emptyModDetails }
else do
-- OK, so we're in one-shot mode.
Succeeded (iface, _path) -> typecheckIface iface
}}}}
where
- need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
- <+> ptext SLIT("to compare against the Real Thing")
+ need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
+ <+> ptext (sLit "to compare against the Real Thing")
- moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
- <+> ptext SLIT("depends on itself")
+ moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod)
+ <+> ptext (sLit "depends on itself")
- elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+>
+ elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
quotes (ppr mod) <> colon) 4 err
\end{code}
tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing
-
-tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
+tcIfaceDecl = tc_iface_decl NoParentTyCon
+
+tc_iface_decl :: TyConParent -- For nested declarations
+ -> Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
+ ifIdDetails = details, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
+ ; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags name ty info
- ; return (AnId (mkVanillaGlobal name ty info)) }
-
-tcIfaceDecl ignore_prags
- (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs,
- ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
- ifCons = rdr_cons,
- ifRec = is_rec,
- ifGeneric = want_generic,
- ifFamInst = mb_family })
- = do { tc_name <- lookupIfaceTop occ_name
- ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
-
- { tycon <- fixM ( \ tycon -> do
+ ; return (AnId (mkGlobalId details name ty info)) }
+
+tc_iface_decl parent _ (IfaceData {ifName = occ_name,
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifRec = is_rec,
+ ifFamInst = mb_family })
+ = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+ { tc_name <- lookupIfaceTop occ_name
+ ; tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; famInst <-
- case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
- do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
- }
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn famInst
+ ; mb_fam_inst <- tcFamInst mb_family
+ ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+ gadt_syn parent mb_fam_inst
})
- ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
- ; return (ATyCon tycon)
- }}
-
-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
- ; rhs_tyki <- tcIfaceType rdr_rhs_ty
- ; let rhs = if isOpen then OpenSynTyCon rhs_tyki
- else SynonymTyCon rhs_tyki
- ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
+ ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+ ; return (ATyCon tycon) }
+
+tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
+ = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+ { tc_name <- lookupIfaceTop occ_name
+ ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; rhs <- forkM (mk_doc tc_name) $
+ tc_syn_rhs mb_rhs_ty
+ ; fam_info <- tcFamInst mb_family
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
+ ; return (ATyCon tycon)
}
+ where
+ mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+ tc_syn_rhs Nothing = return SynFamilyTyCon
+ tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
-tcIfaceDecl ignore_prags
+tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ cls_name <- lookupIfaceTop occ_name
; ctxt <- tcIfaceCtxt rdr_ctxt
- ; sigs <- mappM tc_sig rdr_sigs
- ; fds <- mappM tc_fd rdr_fds
- ; 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
+ ; sigs <- mapM tc_sig rdr_sigs
+ ; fds <- mapM tc_fd rdr_fds
+ ; cls <- fixM $ \ cls -> do
+ { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
+ ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
= do { op_name <- lookupIfaceTop occ
; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
-- Must be done lazily for just the same reason as the
- -- context of a data decl: the type sig might mention the
- -- class being defined
+ -- type of a data con; to avoid sucking in types that
+ -- it mentions unless it's necessray to do so
; return (op_name, dm, op_ty) }
- mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
+ mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
- tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
- ; tvs2' <- mappM tcIfaceTyVar tvs2
+ tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
+ ; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
- -- For each AT argument compute the position of the corresponding class
- -- parameter in the class head. This will later serve as a permutation
- -- vector when checking the validity of instance declarations.
- setTyThingPoss (ATyCon tycon) atTyVars =
- let classTyVars = map fst tv_bndrs
- poss = catMaybes
- . map ((`elemIndex` classTyVars) . fst)
- $ atTyVars
- -- There will be no Nothing, as we already passed renaming
- in
- ATyCon (setTyConArgPoss tycon poss)
- setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
-
-tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
+tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type]))
+tcFamInst Nothing = return Nothing
+tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
+
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
- IfOpenDataTyCon -> return mkOpenDataTyConRhs
- IfOpenNewTyCon -> return mkOpenNewTyConRhs
- IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
+ IfOpenDataTyCon -> return DataFamilyTyCon
+ IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
- ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
+ ; lbl_names <- mapM lookupIfaceTop field_lbls
+
+ -- Remember, tycon is the representation tycon
+ ; let orig_res_ty = mkFamilyTyConApp tycon
+ (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
; buildDataCon name is_infix {- Not infix -}
stricts lbl_names
univ_tyvars ex_tyvars
eq_spec theta
- arg_tys tycon
+ arg_tys orig_res_ty tycon
}
- mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
+ mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
+tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
where
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
-\end{code}
+\end{code}
+
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff). To see why,
+consider this (Trac #2412)
+
+M.hs: module M where { import X; data T = MkT S }
+X.hs: module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot: module M where { data T }
+
+When kind-checking M.hs we need S's kind. But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet! Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+Solution: record S's kind in the interface file; now we can safely
+look at it.
%************************************************************************
%* *
\begin{code}
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
- ifInstCls = cls, ifInstTys = mb_tcs,
- ifInstOrph = orph })
- = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
+ ifInstCls = cls, ifInstTys = mb_tcs })
+ = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
- ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) }
+ ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
ifFamInstFam = fam, ifFamInstTys = mb_tcs })
--- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $
--- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
- = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
- tcIfaceTyCon tycon
- ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
- ; return (mkImportedFamInst fam mb_tcs' tycon') }
+-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
+-- the above line doesn't work, but this below does => CPP in Haskell = evil!
+ = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
+ tcIfaceTyCon tycon
+ let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ return (mkImportedFamInst fam mb_tcs' tycon')
\end{code}
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
- ifRuleOrph = orph })
+ ifRuleAuto = auto })
= do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
- forkM (ptext SLIT("Rule") <+> ftext name) $
+ forkM (ptext (sLit "Rule") <+> ftext name) $
bindIfaceBndrs bndrs $ \ bndrs' ->
- do { args' <- mappM tcIfaceExpr args
+ do { args' <- mapM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
- ; lcl <- getLclEnv
- ; let this_module = if_mod lcl
- ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+ ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
- ru_rhs = rhs', ru_orph = orph,
+ ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
- ru_local = nameModule fn == this_module }) }
+ ru_auto = auto,
+ ru_local = False }) } -- An imported RULE is never for a local Id
+ -- or, even if it is (module loop, perhaps)
+ -- we'll just leave it in the non-local set
where
-- This function *must* mirror exactly what Rules.topFreeName does
-- We could have stored the ru_rough field in the iface file
-- to write them out in coreRuleToIfaceRule
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
- ifTopFreeName (IfaceApp f a) = ifTopFreeName f
+ ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
- ifTopFreeName other = Nothing
+ ifTopFreeName _ = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ Annotations
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceAnnotations = mapM tcIfaceAnnotation
+
+tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
+tcIfaceAnnotation (IfaceAnnotation target serialized) = do
+ target' <- tcIfaceAnnTarget target
+ return $ Annotation {
+ ann_target = target',
+ ann_value = serialized
+ }
+
+tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
+tcIfaceAnnTarget (NamedTarget occ) = do
+ name <- lookupIfaceTop occ
+ return $ NamedTarget name
+tcIfaceAnnTarget (ModuleTarget mod) = do
+ return $ ModuleTarget mod
+
\end{code}
%************************************************************************
%* *
+ Vectorisation information
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo mod typeEnv (IfaceVectInfo
+ { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ })
+ = do { vVars <- mapM vectVarMapping vars
+ ; tyConRes1 <- mapM vectTyConMapping tycons
+ ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
+ ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
+ ; return $ VectInfo
+ { vectInfoVar = mkVarEnv vVars
+ , vectInfoTyCon = mkNameEnv vTyCons
+ , vectInfoDataCon = mkNameEnv (concat vDataCons)
+ , vectInfoPADFun = mkNameEnv vPAs
+ , vectInfoIso = mkNameEnv vIsos
+ }
+ }
+ where
+ vectVarMapping name
+ = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name))
+ ; let { var = lookupVar name
+ ; vVar = lookupVar vName
+ }
+ ; return (var, (var, vVar))
+ }
+ vectTyConMapping name
+ = do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name))
+ ; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name))
+ ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
+ ; let { tycon = lookupTyCon name
+ ; vTycon = lookupTyCon vName
+ ; paTycon = lookupVar paName
+ ; isoTycon = lookupVar isoName
+ }
+ ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
+ ; return ((name, (tycon, vTycon)), -- (T, T_v)
+ vDataCons, -- list of (Ci, Ci_v)
+ (vName, (vTycon, paTycon)), -- (T_v, paT)
+ (name, (tycon, isoTycon))) -- (T, isoT)
+ }
+ vectTyConReuseMapping name
+ = do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name))
+ ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
+ ; let { tycon = lookupTyCon name
+ ; paTycon = lookupVar paName
+ ; isoTycon = lookupVar isoName
+ ; vDataCons = [ (dataConName dc, (dc, dc))
+ | dc <- tyConDataCons tycon]
+ }
+ ; return ((name, (tycon, tycon)), -- (T, T)
+ vDataCons, -- list of (Ci, Ci)
+ (name, (tycon, paTycon)), -- (T, paT)
+ (name, (tycon, isoTycon))) -- (T, isoT)
+ }
+ vectDataConMapping datacon
+ = do { let name = dataConName datacon
+ ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name))
+ ; let vDataCon = lookupDataCon vName
+ ; return (name, (datacon, vDataCon))
+ }
+ --
+ lookupVar name = case lookupTypeEnv typeEnv name of
+ Just (AnId var) -> var
+ Just _ ->
+ panic "TcIface.tcIfaceVectInfo: not an id"
+ Nothing ->
+ panic "TcIface.tcIfaceVectInfo: unknown name"
+ lookupTyCon name = case lookupTypeEnv typeEnv name of
+ Just (ATyCon tc) -> tc
+ Just _ ->
+ panic "TcIface.tcIfaceVectInfo: not a tycon"
+ Nothing ->
+ panic "TcIface.tcIfaceVectInfo: unknown name"
+ lookupDataCon name = case lookupTypeEnv typeEnv name of
+ Just (ADataCon dc) -> dc
+ Just _ ->
+ panic "TcIface.tcIfaceVectInfo: not a datacon"
+ Nothing ->
+ panic "TcIface.tcIfaceVectInfo: unknown name"
+\end{code}
+
+%************************************************************************
+%* *
Types
%* *
%************************************************************************
tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t)
+tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+ = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+ = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+ = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mappM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%* *
+ Coercions
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
+ mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
\end{code}
\begin{code}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
- = tcIfaceType ty `thenM` \ ty' ->
- returnM (Type ty')
+ = Type <$> tcIfaceType ty
+
+tcIfaceExpr (IfaceCo co)
+ = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+ = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
tcIfaceExpr (IfaceLcl name)
- = tcIfaceLclId name `thenM` \ id ->
- returnM (Var id)
+ = Var <$> tcIfaceLclId name
+
+tcIfaceExpr (IfaceTick modName tickNo)
+ = Var <$> tcIfaceTick modName tickNo
tcIfaceExpr (IfaceExt gbl)
- = tcIfaceExtId gbl `thenM` \ id ->
- returnM (Var id)
+ = Var <$> tcIfaceExtId gbl
tcIfaceExpr (IfaceLit lit)
- = returnM (Lit lit)
-
-tcIfaceExpr (IfaceFCall cc ty)
- = tcIfaceType ty `thenM` \ ty' ->
- newUnique `thenM` \ u ->
- returnM (Var (mkFCallId u cc ty'))
-
-tcIfaceExpr (IfaceTuple boxity args)
- = mappM tcIfaceExpr args `thenM` \ args' ->
- let
- -- Put the missing type arguments back in
- con_args = map (Type . exprType) args' ++ args'
- in
- returnM (mkApps (Var con_id) con_args)
+ = return (Lit lit)
+
+tcIfaceExpr (IfaceFCall cc ty) = do
+ ty' <- tcIfaceType ty
+ u <- newUnique
+ return (Var (mkFCallId u cc ty'))
+
+tcIfaceExpr (IfaceTuple boxity args) = do
+ args' <- mapM tcIfaceExpr args
+ -- Put the missing type arguments back in
+ let con_args = map (Type . exprType) args' ++ args'
+ return (mkApps (Var con_id) con_args)
where
arity = length args
con_id = dataConWorkId (tupleCon boxity arity)
tcIfaceExpr (IfaceLam bndr body)
- = bindIfaceBndr bndr $ \ bndr' ->
- tcIfaceExpr body `thenM` \ body' ->
- returnM (Lam bndr' body')
+ = bindIfaceBndr bndr $ \bndr' ->
+ Lam bndr' <$> tcIfaceExpr body
tcIfaceExpr (IfaceApp fun arg)
- = tcIfaceExpr fun `thenM` \ fun' ->
- tcIfaceExpr arg `thenM` \ arg' ->
- returnM (App fun' arg')
+ = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
- = tcIfaceExpr scrut `thenM` \ scrut' ->
- newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name ->
+tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
+ scrut' <- tcIfaceExpr scrut
+ case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
scrut_ty = exprType scrut'
case_bndr' = mkLocalId case_bndr_name scrut_ty
-- NB: not tcSplitTyConApp; we are looking at Core here
-- look through non-rec newtypes to find the tycon that
-- corresponds to the datacon in this case alternative
- in
- extendIfaceIdEnv [case_bndr'] $
- mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
- tcIfaceType ty `thenM` \ ty' ->
- returnM (Case scrut' case_bndr' ty' alts')
-
-tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
- = tcIfaceExpr rhs `thenM` \ rhs' ->
- bindIfaceId bndr $ \ bndr' ->
- tcIfaceExpr body `thenM` \ body' ->
- returnM (Let (NonRec bndr' rhs') body')
-tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
- = bindIfaceIds bndrs $ \ bndrs' ->
- mappM tcIfaceExpr rhss `thenM` \ rhss' ->
- tcIfaceExpr body `thenM` \ body' ->
- returnM (Let (Rec (bndrs' `zip` rhss')) body')
- where
- (bndrs, rhss) = unzip pairs
+ extendIfaceIdEnv [case_bndr'] $ do
+ alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
+ return (Case scrut' case_bndr' (coreAltsType alts') alts')
-tcIfaceExpr (IfaceCast expr co) = do
- expr' <- tcIfaceExpr expr
- co' <- tcIfaceType co
- returnM (Cast expr' co')
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
+ ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+ name ty' info
+ ; let id = mkLocalIdWithInfo name ty' id_info
+ ; rhs' <- tcIfaceExpr rhs
+ ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+ ; return (Let (NonRec id rhs') body') }
-tcIfaceExpr (IfaceNote note expr)
- = tcIfaceExpr expr `thenM` \ expr' ->
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+ = do { ids <- mapM tc_rec_bndr (map fst pairs)
+ ; extendIfaceIdEnv ids $ do
+ { pairs' <- zipWithM tc_pair pairs ids
+ ; body' <- tcIfaceExpr body
+ ; return (Let (Rec pairs') body') } }
+ where
+ tc_rec_bndr (IfLetBndr fs ty _)
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
+ ; return (mkLocalId name ty') }
+ tc_pair (IfLetBndr _ _ info, rhs) id
+ = do { rhs' <- tcIfaceExpr rhs
+ ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+ (idName id) (idType id) info
+ ; return (setIdInfo id id_info, rhs') }
+
+tcIfaceExpr (IfaceNote note expr) = do
+ expr' <- tcIfaceExpr expr
case note of
- IfaceInlineMe -> returnM (Note InlineMe expr')
- IfaceSCC cc -> returnM (Note (SCC cc) expr')
- IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
+ IfaceSCC cc -> return (Note (SCC cc) expr')
+ IfaceCoreNote n -> return (Note (CoreNote n) expr')
-------------------------
-tcIfaceAlt _ (IfaceDefault, names, rhs)
- = ASSERT( null names )
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DEFAULT, [], rhs')
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+ -> (IfaceConAlt, [FastString], IfaceExpr)
+ -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceAlt _ _ (IfaceDefault, names, rhs)
+ = ASSERT( null names ) do
+ rhs' <- tcIfaceExpr rhs
+ return (DEFAULT, [], rhs')
-tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
- = ASSERT( null names )
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (LitAlt lit, [], rhs')
+tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
+ = ASSERT( null names ) do
+ rhs' <- tcIfaceExpr rhs
+ return (LitAlt lit, [], rhs')
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
-tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
= do { con <- tcIfaceDataCon data_occ
- ; ASSERT2( con `elem` tyConDataCons tycon,
- ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
- tcIfaceDataAlt con inst_tys arg_strs rhs }
+ ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+ (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
+ ; tcIfaceDataAlt con inst_tys arg_strs rhs }
-tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
- = ASSERT( isTupleTyCon tycon )
+tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
+ = ASSERT2( isTupleTyCon tycon, ppr tycon )
do { let [data_con] = tyConDataCons tycon
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+ -> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
- ; let (ex_tvs, co_tvs, arg_ids)
+ ; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
- all_tvs = ex_tvs ++ co_tvs
- ; rhs' <- extendIfaceTyVarEnv all_tvs $
+ ; rhs' <- extendIfaceTyVarEnv ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
- ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+ ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
\end{code}
; return (NonRec bndr' rhs' : core_binds) }}
do_one (IfaceRec pairs) thing_inside
- = do { bndrs' <- mappM newExtCoreBndr bndrs
+ = do { bndrs' <- mapM newExtCoreBndr bndrs
; extendIfaceIdEnv bndrs' $ do
- { rhss' <- mappM tcIfaceExpr rhss
+ { rhss' <- mapM tcIfaceExpr rhss
; core_binds <- thing_inside
; return (Rec (bndrs' `zip` rhss') : core_binds) }}
where
%************************************************************************
\begin{code}
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _ IfVanillaId = return VanillaId
+tcIdDetails ty (IfDFunId ns)
+ = return (DFunId ns (isNewTyCon (classTyCon cls)))
+ where
+ (_, _, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
+ = do { tc' <- tcIfaceTyCon tc
+ ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
+
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info
| ignore_prags = return vanillaIdInfo
-- we start; default assumption is that it has CAFs
init_info = vanillaIdInfo
- tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
- tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
- tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
+ tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
+ tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
+ tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
-- The next two are lazy, so they don't transitively suck stuff in
- tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
- tcPrag info (HsInline inline_prag) = returnM (info `setInlinePragInfo` inline_prag)
- tcPrag info (HsUnfold expr)
- = tcPragExpr name expr `thenM` \ maybe_expr' ->
- let
- -- maybe_expr' doesn't get looked at if the unfolding
- -- is never inspected; so the typecheck doesn't even happen
- unfold_info = case maybe_expr' of
- Nothing -> noUnfolding
- Just expr' -> mkTopUnfolding expr'
- in
- returnM (info `setUnfoldingInfoLazily` unfold_info)
+ tcPrag info (HsUnfold lb if_unf)
+ = do { unf <- tcUnfolding name ty info if_unf
+ ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker
+ | otherwise = info
+ ; return (info1 `setUnfoldingInfoLazily` unf) }
\end{code}
\begin{code}
-tcWorkerInfo ty info wkr arity
- = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
-
- -- We return without testing maybe_wkr_id, but as soon as info is
- -- looked at we will test it. That's ok, because its outside the
- -- knot; and there seems no big reason to further defer the
- -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
- -- over the unfolding until it's actually used does seem worth while.)
- ; us <- newUniqueSupply
+tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding name _ info (IfCoreUnfold stable if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; let unf_src = if stable then InlineStable else InlineRhs
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding unf_src
+ True {- Top level -}
+ is_bottoming expr) }
+ where
+ -- Strictness should occur before unfolding!
+ is_bottoming = case strictnessInfo info of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
+
+tcUnfolding name _ _ (IfCompulsory if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCoreUnfolding InlineStable True expr arity
+ (UnfWhen unsat_ok boring_ok))
+ }
- ; returnM (case mb_wkr_id of
- Nothing -> info
- Just wkr_id -> add_wkr_info us wkr_id info) }
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+ = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
+ ; return (case mb_ops1 of
+ Nothing -> noUnfolding
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
- doc = text "Worker for" <+> ppr wkr
- add_wkr_info us wkr_id info
- = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
- `setWorkerInfo` HasWorker wkr_id arity
+ doc = text "Class ops for dfun" <+> ppr name
+ tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
+ tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
+ tc_arg (DFunLamArg i) = return (DFunLamArg i)
+
+tcUnfolding name ty info (IfExtWrapper arity wkr)
+ = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
+tcUnfolding name ty info (IfLclWrapper arity wkr)
+ = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr)
+
+-------------
+tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
+tcIfaceWrapper name ty info arity get_worker
+ = do { mb_wkr_id <- forkM_maybe doc get_worker
+ ; us <- newUniqueSupply
+ ; return (case mb_wkr_id of
+ Nothing -> noUnfolding
+ Just wkr_id -> make_inline_rule wkr_id us) }
+ where
+ doc = text "Worker for" <+> ppr name
- mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ make_inline_rule wkr_id us
+ = mkWwInlineRule wkr_id
+ (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ arity
- -- We are relying here on strictness info always appearing
- -- before worker info, fingers crossed ....
- strict_sig = case newStrictnessInfo info of
+ -- Again we rely here on strictness info always appearing
+ -- before unfolding
+ strict_sig = case strictnessInfo info of
Just sig -> sig
- Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr name)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
\begin{code}
tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr name expr
- = forkM_maybe doc $
- tcIfaceExpr expr `thenM` \ core_expr' ->
-
- -- Check for type consistency in the unfolding
- ifOptM Opt_DoCoreLinting (
- get_in_scope_ids `thenM` \ in_scope ->
- case lintUnfolding noSrcLoc in_scope core_expr' of
- Nothing -> returnM ()
- Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
- ) `thenM_`
-
- returnM core_expr'
+ = forkM_maybe doc $ do
+ core_expr' <- tcIfaceExpr expr
+
+ -- Check for type consistency in the unfolding
+ ifDOptM Opt_DoCoreLinting $ do
+ in_scope <- get_in_scope
+ case lintUnfolding noSrcLoc in_scope core_expr' of
+ Nothing -> return ()
+ Just fail_msg -> do { mod <- getIfModule
+ ; pprPanic "Iface Lint failure"
+ (vcat [ ptext (sLit "In interface for") <+> ppr mod
+ , hang doc 2 fail_msg
+ , ppr name <+> equals <+> ppr core_expr'
+ , ptext (sLit "Iface expr =") <+> ppr expr ]) }
+ return core_expr'
where
doc = text "Unfolding of" <+> ppr name
- get_in_scope_ids -- Urgh; but just for linting
- = setLclEnv () $
- do { env <- getGblEnv
- ; case if_rec_types env of {
- Nothing -> return [] ;
- Just (_, get_env) -> do
- { type_env <- get_env
- ; return (typeEnvIds type_env) }}}
+
+ get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+ get_in_scope
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; rec_ids <- case if_rec_types gbl_env of
+ Nothing -> return []
+ Just (_, get_env) -> do
+ { type_env <- setLclEnv () get_env
+ ; return (typeEnvIds type_env) }
+ ; return (varEnvElts (if_tv_env lcl_env) ++
+ varEnvElts (if_id_env lcl_env) ++
+ rec_ids) }
\end{code}
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
-- Wired-in things include TyCons, DataCons, and Ids
- = do { ifCheckWiredInThing name; return thing }
+ = do { ifCheckWiredInThing thing; return thing }
| otherwise
- = do { (eps,hpt) <- getEpsAndHpt
- ; dflags <- getDOpts
- ; case lookupType dflags hpt (eps_PTE eps) name of {
- Just thing -> return thing ;
- Nothing -> do
-
- { env <- getGblEnv
- ; case if_rec_types env of {
+ = do { env <- getGblEnv
+ ; case if_rec_types env of { -- Note [Tying the knot]
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do -- It's defined in the module being compiled
{ type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
- Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
- ; other -> do
+ ; _ -> do
+
+ { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+ ; case mb_thing of {
+ Just thing -> return thing ;
+ Nothing -> do
{ mb_thing <- importDecl name -- It's imported; go get it
; case mb_thing of
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) }
+-- Note [Tying the knot]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- The if_rec_types field is used in two situations:
+--
+-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T
+-- Then we look up M.T in M's type environment, which is splatted into if_rec_types
+-- after we've built M's type envt.
+--
+-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi
+-- is up to date. So we call typecheckIface on M.hi. This splats M.T into
+-- if_rec_types so that the (lazily typechecked) decls see all the other decls
+--
+-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT
+-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its
+-- emasculated form (e.g. lacking data constructors).
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind
+ ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
-#ifdef DEBUG
- check_tc tc = case toIfaceTyCon tc of
- IfaceTc _ -> tc
- other -> pprTrace "check_tc" (ppr tc) tc
-#else
- check_tc tc = tc
-#endif
+ check_tc tc
+ | debugIsOn = case toIfaceTyCon tc of
+ IfaceTc _ -> tc
+ _ -> pprTrace "check_tc" (ppr tc) tc
+ | otherwise = tc
-- we should be okay just returning Kind constructors without extra loading
tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon
-- sure the instances and RULES of this tycon are loaded
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
-tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc)
+tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc)
; return tc }
tcIfaceClass :: Name -> IfL Class
tcIfaceClass name = do { thing <- tcIfaceGlobal name
; return (tyThingClass thing) }
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+ ; return (tyThingCoAxiom thing) }
+
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
ADataCon dc -> return dc
- other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
- other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+ _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
\end{code}
%************************************************************************
\begin{code}
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
-bindIfaceBndr (IfaceIdBndr bndr) thing_inside
- = bindIfaceId bndr thing_inside
+bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
+ ; let id = mkLocalId name ty'
+ ; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
thing_inside (b':bs')
-----------------------
-bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
-bindIfaceId (occ, ty) thing_inside
- = do { name <- newIfaceName (mkVarOccFS occ)
- ; ty' <- tcIfaceType ty
- ; let { id = mkLocalId name ty' }
- ; extendIfaceIdEnv [id] (thing_inside id) }
-
-bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
-bindIfaceIds bndrs thing_inside
- = do { names <- newIfaceNames (map mkVarOccFS occs)
- ; tys' <- mappM tcIfaceType tys
- ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
- ; extendIfaceIdEnv ids (thing_inside ids) }
- where
- (occs,tys) = unzip bndrs
-
-
------------------------
-newExtCoreBndr :: IfaceIdBndr -> IfL Id
-newExtCoreBndr (var, ty)
+newExtCoreBndr :: IfaceLetBndr -> IfL Id
+newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now
= do { mod <- getIfModule
- ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc
+ ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
-----------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
- = do { name <- newIfaceName (mkTyVarOcc occ)
+ = do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
- = do { names <- newIfaceNames (map mkTyVarOcc occs)
- ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds
+ = do { names <- newIfaceNames (map mkTyVarOccFS occs)
+ ; tyvars <- zipWithM mk_iface_tyvar names kinds
; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
where
(occs,kinds) = unzip bndrs
return (Var.mkCoVar name kind)
else
return (Var.mkTyVar name kind) }
-\end{code}
+
+bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+-- class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyVars_AT [] thing_inside
+ = thing_inside []
+bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
+ = bindIfaceTyVars_AT bs $ \ bs' ->
+ do { mb_tv <- lookupIfaceTyVar tv_occ
+ ; case mb_tv of
+ Just b' -> thing_inside (b':bs')
+ Nothing -> bindIfaceTyVar b $ \ b' ->
+ thing_inside (b':bs') }
+\end{code}
projects / ghc-hetmet.git / blobdiff