X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=7e6406fe710c176aacedea08bea843ea0caf4a6f;hb=8e3b5645e0bab683444c81bbbac87e2df6799959;hp=8bbb79a63b17cc60158b3972ff42a179342c0cae;hpb=d33c0b24a0306cc57161b7ed7ff2510d0b017b11;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8bbb79a..7e6406f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -8,8 +8,8 @@ Type checking of type signatures in interface files \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" @@ -38,6 +38,7 @@ import DataCon import TysWiredIn import Var ( TyVar ) import qualified Var +import VarEnv import Name import NameEnv import OccName @@ -104,6 +105,7 @@ tcImportDecl :: Name -> TcM TyThing 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) @@ -114,7 +116,8 @@ tcImportDecl 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) @@ -198,6 +201,10 @@ typecheckIface iface ; 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) @@ -208,6 +215,7 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_vect_info = vect_info , md_exports = exports , md_modBreaks = emptyModBreaks } @@ -377,13 +385,22 @@ tcIfaceDecl ignore_prags 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 @@ -439,7 +456,6 @@ tcIfaceDataCons tycon_name tycon tc_tyvars 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 ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -483,7 +499,7 @@ tcIfaceEqSpec spec do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) ; ty <- tcIfaceType if_ty ; return (tv,ty) } -\end{code} +\end{code} %************************************************************************ @@ -570,6 +586,88 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd %************************************************************************ %* * + Vectorisation information +%* * +%************************************************************************ + +\begin{code} +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceVectInfo mod typeEnv (IfaceVectInfo + { ifaceVectInfoCCVar = vars + , ifaceVectInfoCCTyCon = tycons + , ifaceVectInfoCCTyConReuse = tyconsReuse + }) + = do { ccVars <- mapM ccVarMapping vars + ; tyConRes1 <- mapM ccTyConMapping tycons + ; tyConRes2 <- mapM ccTyConReuseMapping tycons + ; let (ccTyCons, ccDataCons, ccIsos) = unzip3 (tyConRes1 ++ tyConRes2) + ; return $ VectInfo + { vectInfoCCVar = mkVarEnv ccVars + , vectInfoCCTyCon = mkNameEnv ccTyCons + , vectInfoCCDataCon = mkNameEnv (concat ccDataCons) + , vectInfoCCIso = mkNameEnv ccIsos + } + } + where + ccVarMapping name + = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) + ; let { var = lookupVar name + ; ccVar = lookupVar ccName + } + ; return (var, (var, ccVar)) + } + ccTyConMapping name + = do { ccName <- lookupOrig mod (mkCloTyConOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; ccTycon = lookupTyCon ccName + ; isoTycon = lookupVar isoName + } + ; ccDataCons <- mapM ccDataConMapping (tyConDataCons tycon) + ; return ((name, (tycon, ccTycon)), -- (T, T_CC) + ccDataCons, -- list of (Ci, Ci_CC) + (name, (tycon, isoTycon))) -- (T, isoT) + } + ccTyConReuseMapping name + = do { isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; isoTycon = lookupVar isoName + ; ccDataCons = [ (dataConName dc, (dc, dc)) + | dc <- tyConDataCons tycon] + } + ; return ((name, (tycon, tycon)), -- (T, T) + ccDataCons, -- list of (Ci, Ci) + (name, (tycon, isoTycon))) -- (T, isoT) + } + ccDataConMapping datacon + = do { let name = dataConName datacon + ; ccName <- lookupOrig mod (mkCloDataConOcc (nameOccName name)) + ; let ccDataCon = lookupDataCon ccName + ; return (name, (datacon, ccDataCon)) + } + -- + 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 %* * %************************************************************************ @@ -895,6 +993,7 @@ 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 +-- See Note [Loading instances] in LoadIface ifCheckWiredInThing name = do { mod <- getIfModule -- Check whether we are typechecking the interface for this @@ -996,7 +1095,7 @@ tcIfaceLetBndr (IfLetBndr fs ty info) 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') }