\begin{code}
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal,
- tcExtCoreBindings
+ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+ tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
import TysWiredIn
import Var ( TyVar )
import qualified Var
+import VarEnv
import Name
import NameEnv
import OccName
import ErrUtils
import Maybes
import SrcLoc
-import Util
import DynFlags
-import Breakpoints
import Control.Monad
import Data.List
tcImportDecl name
| Just thing <- wiredInNameTyThing_maybe name
= do { initIfaceTcRn (loadWiredInHomeIface name)
+ -- See Note [Loading instances] in LoadIface
; return thing }
| otherwise
= do { traceIf (text "tcImportDecl" <+> ppr name)
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),
+-- are loaded. See See Note [Loading instances] in LoadIface
+-- 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)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules 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_vect_info = vect_info
, md_exports = exports
- , md_dbg_sites = noDbgSites
+ , md_modBreaks = emptyModBreaks
}
}
\end{code}
tcIfaceDecl ignore_prags
(IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
+ ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
+ ifFamInst = mb_family})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_tyki <- tcIfaceType rdr_rhs_ty
; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
else SynonymTyCon rhs_tyki
- ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
+ ; famInst <- case mb_family of
+ Nothing -> return Nothing
+ Just (fam, tys) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
+ ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+ ; return $ ATyCon tycon
}
tcIfaceDecl ignore_prags
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
- IfOpenNewTyCon -> return mkOpenNewTyConRhs
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
-\end{code}
+\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 tycons
+ ; let (vTyCons, vDataCons, vIsos) = unzip3 (tyConRes1 ++ tyConRes2)
+ ; return $ VectInfo
+ { vectInfoVar = mkVarEnv vVars
+ , vectInfoTyCon = mkNameEnv vTyCons
+ , vectInfoDataCon = mkNameEnv (concat vDataCons)
+ , 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))
+ ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
+ ; let { tycon = lookupTyCon name
+ ; vTycon = lookupTyCon vName
+ ; isoTycon = lookupVar isoName
+ }
+ ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
+ ; return ((name, (tycon, vTycon)), -- (T, T_v)
+ vDataCons, -- list of (Ci, Ci_v)
+ (name, (tycon, isoTycon))) -- (T, isoT)
+ }
+ vectTyConReuseMapping name
+ = do { isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
+ ; let { tycon = lookupTyCon name
+ ; isoTycon = lookupVar isoName
+ ; vDataCons = [ (dataConName dc, (dc, dc))
+ | dc <- tyConDataCons tycon]
+ }
+ ; return ((name, (tycon, tycon)), -- (T, T)
+ vDataCons, -- list of (Ci, Ci)
+ (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
%* *
%************************************************************************
= tcIfaceLclId name `thenM` \ id ->
returnM (Var id)
+tcIfaceExpr (IfaceTick modName tickNo)
+ = tcIfaceTick modName tickNo `thenM` \ id ->
+ returnM (Var id)
+
tcIfaceExpr (IfaceExt gbl)
= tcIfaceExtId gbl `thenM` \ id ->
returnM (Var id)
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')
+ = do { rhs' <- tcIfaceExpr rhs
+ ; id <- tcIfaceLetBndr bndr
+ ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+ ; return (Let (NonRec id 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')
+ = do { ids <- mapM tcIfaceLetBndr bndrs
+ ; extendIfaceIdEnv ids $ do
+ { rhss' <- mapM tcIfaceExpr rhss
+ ; body' <- tcIfaceExpr body
+ ; return (Let (Rec (ids `zip` rhss')) body') } }
where
(bndrs, rhss) = unzip pairs
-- 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] in LoadIface
ifCheckWiredInThing name
= do { mod <- getIfModule
-- Check whether we are typechecking the interface for this
\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)
+tcIfaceLetBndr (IfLetBndr fs ty info)
+ = do { name <- newIfaceName (mkVarOccFS fs)
; 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) }
+ ; case info of
+ NoInfo -> return (mkLocalId name ty')
+ HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) }
where
- (occs,tys) = unzip bndrs
-
+ -- Similar to tcIdInfo, but much simpler
+ tc_info [] = vanillaIdInfo
+ tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p
+ tc_info (HsArity a : i) = tc_info i `setArityInfo` a
+ tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s
+ tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo"
+ (ppr other) (tc_info i)
-----------------------
-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') }