X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=7416a5f0d886c236937512ae11659a892aab4ec1;hb=b0c46848af7e431a2898af1a8aa1fbb0d2499137;hp=a90d069d1c4cd0ca83c72abcbc04d333ef8e0afc;hpb=e5f78a4a5309b598d5195aa49a0bf7a206942cea;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a90d069..7416a5f 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,9 +38,9 @@ import DataCon import TysWiredIn import Var ( TyVar ) import qualified Var +import VarEnv import Name import NameEnv -import NameSet import OccName import Module import UniqFM @@ -105,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) @@ -115,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) @@ -200,8 +202,8 @@ typecheckIface iface ; rules <- tcIfaceRules ignore_prags (mi_rules iface) -- Vectorisation information - ; let vect_info = VectInfo - (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface))) + ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env + (mi_vect_info iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -383,14 +385,21 @@ 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 - -- !!!TODO: read mb_family info from iface and pass as last argument - ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing + ; 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 } @@ -447,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 @@ -491,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} %************************************************************************ @@ -578,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 + { 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 %* * %************************************************************************ @@ -621,6 +711,10 @@ tcIfaceExpr (IfaceLcl name) = 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) @@ -903,6 +997,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 @@ -1004,7 +1099,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') }