Break out Repr and PADict stuff for vectorisation of ADTs to their own modules

[ghc-hetmet.git] / compiler / vectorise / Vectorise / Type / Repr.hs

diff --git a/compiler/vectorise/Vectorise/Type/Repr.hs b/compiler/vectorise/Vectorise/Type/Repr.hs
new file mode 100644 (file)
index 0000000..ea06d1f
--- /dev/null
+++ b/compiler/vectorise/Vectorise/Type/Repr.hs
@@ -0,0 +1,111 @@
+
+-- | Representation of Algebraic Data Types.
+module Vectorise.Type.Repr
+       ( CompRepr      (..)
+       , ProdRepr      (..)
+       , ConRepr       (..)
+       , SumRepr       (..)
+       , tyConRepr
+       , sumReprType
+       , conReprType
+       , prodReprType
+       , compReprType
+       , compOrigType)
+where
+import VectUtils
+import Vectorise.Monad
+import Vectorise.Builtins
+
+import CoreSyn
+import DataCon
+import TyCon
+import Type
+import Control.Monad
+
+
+data CompRepr = Keep Type
+                     CoreExpr     -- PR dictionary for the type
+              | Wrap Type
+
+data ProdRepr = EmptyProd
+              | UnaryProd CompRepr
+              | Prod { repr_tup_tc   :: TyCon  -- representation tuple tycon
+                     , repr_ptup_tc  :: TyCon  -- PData representation tycon
+                     , repr_comp_tys :: [Type] -- representation types of
+                     , repr_comps    :: [CompRepr]          -- components
+                     }
+data ConRepr  = ConRepr DataCon ProdRepr
+
+data SumRepr  = EmptySum
+              | UnarySum ConRepr
+              | Sum  { repr_sum_tc   :: TyCon  -- representation sum tycon
+                     , repr_psum_tc  :: TyCon  -- PData representation tycon
+                     , repr_sel_ty   :: Type   -- type of selector
+                     , repr_con_tys :: [Type]  -- representation types of
+                     , repr_cons     :: [ConRepr]           -- components
+                     }
+
+tyConRepr :: TyCon -> VM SumRepr
+tyConRepr tc = sum_repr (tyConDataCons tc)
+  where
+    sum_repr []    = return EmptySum
+    sum_repr [con] = liftM UnarySum (con_repr con)
+    sum_repr cons  = do
+                       rs     <- mapM con_repr cons
+                       sum_tc <- builtin (sumTyCon arity)
+                       tys    <- mapM conReprType rs
+                       (psum_tc, _) <- pdataReprTyCon (mkTyConApp sum_tc tys)
+                       sel_ty <- builtin (selTy arity)
+                       return $ Sum { repr_sum_tc  = sum_tc
+                                    , repr_psum_tc = psum_tc
+                                    , repr_sel_ty  = sel_ty
+                                    , repr_con_tys = tys
+                                    , repr_cons    = rs
+                                    }
+      where
+        arity = length cons
+
+    con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con))
+
+    prod_repr []   = return EmptyProd
+    prod_repr [ty] = liftM UnaryProd (comp_repr ty)
+    prod_repr tys  = do
+                       rs <- mapM comp_repr tys
+                       tup_tc <- builtin (prodTyCon arity)
+                       tys'    <- mapM compReprType rs
+                       (ptup_tc, _) <- pdataReprTyCon (mkTyConApp tup_tc tys')
+                       return $ Prod { repr_tup_tc   = tup_tc
+                                     , repr_ptup_tc  = ptup_tc
+                                     , repr_comp_tys = tys'
+                                     , repr_comps    = rs
+                                     }
+      where
+        arity = length tys
+    
+    comp_repr ty = liftM (Keep ty) (prDictOfType ty)
+                   `orElseV` return (Wrap ty)
+
+sumReprType :: SumRepr -> VM Type
+sumReprType EmptySum = voidType
+sumReprType (UnarySum r) = conReprType r
+sumReprType (Sum { repr_sum_tc  = sum_tc, repr_con_tys = tys })
+  = return $ mkTyConApp sum_tc tys
+
+conReprType :: ConRepr -> VM Type
+conReprType (ConRepr _ r) = prodReprType r
+
+prodReprType :: ProdRepr -> VM Type
+prodReprType EmptyProd = voidType
+prodReprType (UnaryProd r) = compReprType r
+prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })
+  = return $ mkTyConApp tup_tc tys
+
+compReprType :: CompRepr -> VM Type
+compReprType (Keep ty _) = return ty
+compReprType (Wrap ty) = do
+                             wrap_tc <- builtin wrapTyCon
+                             return $ mkTyConApp wrap_tc [ty]
+
+compOrigType :: CompRepr -> Type
+compOrigType (Keep ty _) = ty
+compOrigType (Wrap ty) = ty