From b0ba46e41c0ed8ee649e6ca4ae5c4e6e7f36d260 Mon Sep 17 00:00:00 2001 From: "benl@ouroborus.net" Date: Wed, 8 Sep 2010 06:31:11 +0000 Subject: [PATCH] Break out TyCon classifier into own module --- compiler/ghc.cabal.in | 1 + compiler/vectorise/VectType.hs | 93 +++++-------------------- compiler/vectorise/Vectorise/Type/Classify.hs | 91 ++++++++++++++++++++++++ 3 files changed, 108 insertions(+), 77 deletions(-) create mode 100644 compiler/vectorise/Vectorise/Type/Classify.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 564cd95..640aece 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -461,6 +461,7 @@ Library Vectorise.Vect Vectorise.Type.Type Vectorise.Type.TyConDecl + Vectorise.Type.Classify Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index b8b851f..4b7cc47 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -13,6 +13,7 @@ import Vectorise.Monad import Vectorise.Builtins import Vectorise.Type.Type import Vectorise.Type.TyConDecl +import Vectorise.Type.Classify import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import BasicTypes @@ -36,9 +37,7 @@ import NameEnv import Unique import UniqFM -import UniqSet import Util -import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) import Outputable import FastString @@ -50,14 +49,10 @@ import Data.List debug = False dtrace s x = if debug then pprTrace "VectType" s x else x --- ---------------------------------------------------------------------------- --- Types - -- ---------------------------------------------------------------------------- -- Type definitions -type TyConGroup = ([TyCon], UniqSet TyCon) -- | Vectorise a type environment. -- The type environment contains all the type things defined in a module. @@ -751,71 +746,6 @@ paMethods = [("dictPRepr", buildPRDict), ("fromArrPRepr", buildFromArrPRepr)] --- | Split the given tycons into two sets depending on whether they have to be --- converted (first list) or not (second list). The first argument contains --- information about the conversion status of external tycons: --- --- * tycons which have converted versions are mapped to True --- * tycons which are not changed by vectorisation are mapped to False --- * tycons which can't be converted are not elements of the map --- -classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon]) -classifyTyCons = classify [] [] - where - classify conv keep _ [] = (conv, keep) - classify conv keep cs ((tcs, ds) : rs) - | can_convert && must_convert - = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs - | can_convert - = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs - | otherwise - = classify conv keep cs rs - where - refs = ds `delListFromUniqSet` tcs - - can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs - must_convert = foldUFM (||) False (intersectUFM_C const cs refs) - - convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc) - --- | Compute mutually recursive groups of tycons in topological order --- -tyConGroups :: [TyCon] -> [TyConGroup] -tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges) - where - edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs - , let ds = tyConsOfTyCon tc] - - mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) - mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) - where - (tcs, dss) = unzip els - -tyConsOfTyCon :: TyCon -> UniqSet TyCon -tyConsOfTyCon - = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons - -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - | Just ty' <- coreView ty = tyConsOfType ty' -tyConsOfType (TyVarTy _) = emptyUniqSet -tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) - where - extend | isUnLiftedTyCon tc - || isTupleTyCon tc = id - - | otherwise = (`addOneToUniqSet` tc) - -tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b -tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) - `addOneToUniqSet` funTyCon -tyConsOfType (ForAllTy _ ty) = tyConsOfType ty -tyConsOfType other = pprPanic "ClosureConv.tyConsOfType" $ ppr other - -tyConsOfTypes :: [Type] -> UniqSet TyCon -tyConsOfTypes = unionManyUniqSets . map tyConsOfType - - -- ---------------------------------------------------------------------------- -- Conversions @@ -860,23 +790,32 @@ fromVect ty expr = identityConv ty >> return expr +-- TODO: What is this really doing? toVect :: Type -> CoreExpr -> VM CoreExpr toVect ty expr = identityConv ty >> return expr +-- | Check that we have the vectorised versions of all the +-- type constructors in this type. identityConv :: Type -> VM () -identityConv ty | Just ty' <- coreView ty = identityConv ty' +identityConv ty + | Just ty' <- coreView ty + = identityConv ty' + identityConv (TyConApp tycon tys) - = do - mapM_ identityConv tys + = do mapM_ identityConv tys identityConvTyCon tycon + identityConv _ = noV + +-- | Check that we have the vectorised version of this type constructor. identityConvTyCon :: TyCon -> VM () identityConvTyCon tc | isBoxedTupleTyCon tc = return () | isUnLiftedTyCon tc = return () - | otherwise = do - tc' <- maybeV (lookupTyCon tc) - if tc == tc' then return () else noV + | otherwise + = do tc' <- maybeV (lookupTyCon tc) + if tc == tc' then return () else noV + diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs new file mode 100644 index 0000000..79cd035 --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -0,0 +1,91 @@ + +module Vectorise.Type.Classify + ( TyConGroup + , classifyTyCons + , tyConGroups) +where +import UniqSet +import UniqFM +import DataCon +import TyCon +import TypeRep +import Type +import Digraph +import Outputable + +type TyConGroup = ([TyCon], UniqSet TyCon) + +-- | Split the given tycons into two sets depending on whether they have to be +-- converted (first list) or not (second list). The first argument contains +-- information about the conversion status of external tycons: +-- +-- * tycons which have converted versions are mapped to True +-- * tycons which are not changed by vectorisation are mapped to False +-- * tycons which can't be converted are not elements of the map +-- +classifyTyCons + :: UniqFM Bool + -> [TyConGroup] + -> ([TyCon], [TyCon]) + +classifyTyCons = classify [] [] + where + classify conv keep _ [] = (conv, keep) + classify conv keep cs ((tcs, ds) : rs) + | can_convert && must_convert + = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs + | can_convert + = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs + | otherwise + = classify conv keep cs rs + where + refs = ds `delListFromUniqSet` tcs + + can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs + must_convert = foldUFM (||) False (intersectUFM_C const cs refs) + + convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc) + + +-- | Compute mutually recursive groups of tycons in topological order +tyConGroups :: [TyCon] -> [TyConGroup] +tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges) + where + edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs + , let ds = tyConsOfTyCon tc] + + mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) + mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) + where + (tcs, dss) = unzip els + + +-- | Collect the set of TyCons used by the representation of some data type. +tyConsOfTyCon :: TyCon -> UniqSet TyCon +tyConsOfTyCon + = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons + + +-- | Collect the set of TyCons that occur in these types. +tyConsOfTypes :: [Type] -> UniqSet TyCon +tyConsOfTypes = unionManyUniqSets . map tyConsOfType + + +-- | Collect the set of TyCons that occur in this type. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + | Just ty' <- coreView ty = tyConsOfType ty' +tyConsOfType (TyVarTy _) = emptyUniqSet +tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) + where + extend | isUnLiftedTyCon tc + || isTupleTyCon tc = id + + | otherwise = (`addOneToUniqSet` tc) + +tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b +tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) + `addOneToUniqSet` funTyCon +tyConsOfType (ForAllTy _ ty) = tyConsOfType ty +tyConsOfType other = pprPanic "ClosureConv.tyConsOfType" $ ppr other + -- 1.7.10.4