From: Manuel M T Chakravarty Date: Tue, 22 May 2007 09:27:29 +0000 (+0000) Subject: Add data type information to VectInfo X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=686d87447e2186e2aa55e1a925f0a3a8e94872f5 Add data type information to VectInfo --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 0ffd37d..4664bf1 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1222,10 +1222,14 @@ instance Binary IfaceRule where return (IfaceRule a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1) = do + put_ bh (IfaceVectInfo a1 a2 a3) = do put_ bh a1 + put_ bh a2 + put_ bh a3 get bh = do a1 <- get bh - return (IfaceVectInfo a1) + a2 <- get bh + a3 <- get bh + return (IfaceVectInfo a1 a2 a3) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e6c8f63..8ca7b41 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -655,8 +655,15 @@ pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes pprFix (occ,fix) = ppr fix <+> ppr occ pprVectInfo :: IfaceVectInfo -> SDoc -pprVectInfo (IfaceVectInfo names) = - ptext SLIT("Closured converted:") <+> hsep (map ppr names) +pprVectInfo (IfaceVectInfo { ifaceVectInfoCCVar = vars + , ifaceVectInfoCCTyCon = tycons + , ifaceVectInfoCCTyConReuse = tyconsReuse + }) = + vcat + [ ptext SLIT("CC'ed variables:") <+> hsep (map ppr vars) + , ptext SLIT("CC'ed tycons:") <+> hsep (map ppr tycons) + , ptext SLIT("CC reused tycons:") <+> hsep (map ppr tyconsReuse) + ] pprDeprecs NoDeprecs = empty pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 4dd3c82..22fd309 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -339,8 +339,19 @@ mkIface hsc_env maybe_old_iface deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - flattenVectInfo (VectInfo ccVar) = - IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar] + flattenVectInfo (VectInfo { vectInfoCCVar = ccVar + , vectInfoCCTyCon = ccTyCon + }) = + IfaceVectInfo { + ifaceVectInfoCCVar = [ Var.varName v + | (v, _) <- varEnvElts ccVar], + ifaceVectInfoCCTyCon = [ tyConName t + | (t, t_CC) <- nameEnvElts ccTyCon + , t /= t_CC], + ifaceVectInfoCCTyConReuse = [ tyConName t + | (t, t_CC) <- nameEnvElts ccTyCon + , t == t_CC] + } ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c887e02..bae0405 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -497,7 +497,7 @@ tcIfaceEqSpec spec do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) ; ty <- tcIfaceType if_ty ; return (tv,ty) } -\end{code} +\end{code} %************************************************************************ @@ -590,24 +590,78 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceVectInfo mod typeEnv (IfaceVectInfo names) - = do { ccVars <- mapM ccMapping names - ; return $ VectInfo (mkVarEnv ccVars) +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 - ccMapping name + ccVarMapping name = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) - ; let { var = lookup name - ; ccVar = lookup ccName + ; let { var = lookupVar name + ; ccVar = lookupVar ccName } ; return (var, (var, ccVar)) } - lookup name = case lookupTypeEnv typeEnv name of - Just (AnId var) -> var - Just _ -> - panic "TcIface.tcIfaceVectInfo: wrong TyThing" - Nothing -> - panic "TcIface.tcIfaceVectInfo: unknown name" + 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} %************************************************************************ diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 956d10d..fb8e87e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1255,28 +1255,42 @@ on just the OccName easily in a Core pass. -- ModGuts/ModDetails/EPS version data VectInfo = VectInfo { - vectInfoCCVar :: VarEnv (Var, Var) -- (f, f_CC) keyed on f - -- always tidy, even in ModGuts + vectInfoCCVar :: VarEnv (Var , Var ), -- (f, f_CC) keyed on f + vectInfoCCTyCon :: NameEnv (TyCon , TyCon), -- (T, T_CC) keyed on T + vectInfoCCDataCon :: NameEnv (DataCon, DataCon), -- (C, C_CC) keyed on C + vectInfoCCIso :: NameEnv (TyCon , Var) -- (T, isoT) keyed on T } + -- all of this is always tidy, even in ModGuts -- ModIface version data IfaceVectInfo = IfaceVectInfo { - ifaceVectInfoCCVar :: [Name] -- all variables in here have - -- a closure-converted variant - -- the name of the CC'ed variant - -- is determined by `mkCloOcc' + ifaceVectInfoCCVar :: [Name], + -- all variables in here have a closure-converted variant; + -- the name of the CC'ed variant is determined by `mkCloOcc' + ifaceVectInfoCCTyCon :: [Name], + -- all tycons in here have a closure-converted variant; + -- the name of the CC'ed variant and those of its data constructors are + -- determined by `mkCloTyConOcc' and `mkCloDataConOcc'; the names of + -- the isomorphisms is determined by `mkCloIsoOcc' + ifaceVectInfoCCTyConReuse :: [Name] + -- the closure-converted form of all the tycons in here coincids with + -- the unconverted from; the names of the isomorphisms is determined + -- by `mkCloIsoOcc' } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyVarEnv +noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 vi2 = - VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2) + VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2) + (vectInfoCCTyCon vi1 `plusNameEnv` vectInfoCCTyCon vi2) + (vectInfoCCDataCon vi1 `plusNameEnv` vectInfoCCDataCon vi2) + (vectInfoCCIso vi1 `plusNameEnv` vectInfoCCIso vi2) noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] +noIfaceVectInfo = IfaceVectInfo [] [] [] \end{code} %************************************************************************