X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=08a8067561d40040c0141b6849eb38a1071ada59;hb=020f85464387244a063acad967e88132ba715982;hp=d5a1ba1281231a22ac6bb58bfd080948ee0eac4a;hpb=6c63c674e5fa0ec8a445d9947584aaf6c2d3ac52;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index d5a1ba1..08a8067 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -7,17 +7,22 @@ import VectMonad import VectUtils import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) +import CoreSyn import DataCon import TyCon import Type import TypeRep import Coercion +import FamInstEnv ( FamInst, mkLocalFamInst ) +import InstEnv ( Instance ) import OccName import MkId import BasicTypes ( StrictnessMark(..), boolToRecFlag ) +import Id ( mkWildId ) import Name ( Name ) import NameEnv -import TysWiredIn ( intTy ) +import TysWiredIn ( intTy, intDataCon ) +import TysPrim ( intPrimTy ) import Unique import UniqFM @@ -26,7 +31,8 @@ import Digraph ( SCC(..), stronglyConnComp ) import Outputable -import Control.Monad ( liftM2, zipWithM, zipWithM_ ) +import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_ ) +import Data.List ( inits, tails ) -- ---------------------------------------------------------------------------- -- Types @@ -66,7 +72,7 @@ vectType ty = pprPanic "vectType:" (ppr ty) type TyConGroup = ([TyCon], UniqSet TyCon) -vectTypeEnv :: TypeEnv -> VM TypeEnv +vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [Instance]) vectTypeEnv env = do cs <- readGEnv $ mk_map . global_tycons @@ -75,12 +81,16 @@ vectTypeEnv env zipWithM_ defTyCon keep_tcs keep_tcs zipWithM_ defDataCon keep_dcs keep_dcs vect_tcs <- vectTyConDecls conv_tcs - parr_tcs1 <- mapM (\tc -> buildPArrayTyCon (tyConName tc) tc) keep_tcs - parr_tcs2 <- zipWithM (buildPArrayTyCon . tyConName) conv_tcs vect_tcs + parr_tcs1 <- zipWithM buildPArrayTyCon keep_tcs keep_tcs + parr_tcs2 <- zipWithM buildPArrayTyCon conv_tcs vect_tcs let new_tcs = vect_tcs ++ parr_tcs1 ++ parr_tcs2 - return $ extendTypeEnvList env - (map ATyCon new_tcs ++ [ADataCon dc | tc <- new_tcs - , dc <- tyConDataCons tc]) + + let new_env = extendTypeEnvList env + (map ATyCon new_tcs + ++ [ADataCon dc | tc <- new_tcs + , dc <- tyConDataCons tc]) + + return (new_env, map mkLocalFamInst (parr_tcs1 ++ parr_tcs2), []) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -167,8 +177,8 @@ vectDataCon dc rep_arg_tys = dataConRepArgTys dc tycon = dataConTyCon dc -buildPArrayTyCon :: Name -> TyCon -> VM TyCon -buildPArrayTyCon orig_name vect_tc = fixV $ \repr_tc -> +buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon +buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> do name' <- cloneName mkPArrayTyConOcc orig_name parent <- buildPArrayParentInfo orig_name vect_tc repr_tc @@ -185,6 +195,7 @@ buildPArrayTyCon orig_name vect_tc = fixV $ \repr_tc -> False -- FIXME: no generics False -- not GADT syntax where + orig_name = tyConName orig_tc name = tyConName vect_tc kind = tyConKind vect_tc tyvars = tyConTyVars vect_tc @@ -195,7 +206,7 @@ buildPArrayParentInfo :: Name -> TyCon -> TyCon -> VM TyConParent buildPArrayParentInfo orig_name vect_tc repr_tc = do parray_tc <- builtin parrayTyCon - co_name <- cloneName mkInstTyCoOcc orig_name + co_name <- cloneName mkInstTyCoOcc (tyConName repr_tc) let inst_tys = [mkTyConApp vect_tc (map mkTyVarTy tyvars)] @@ -242,6 +253,89 @@ buildPArrayDataCon orig_name vect_tc repr_tc types = [ty | dc <- tyConDataCons vect_tc , ty <- dataConRepArgTys dc] +buildLengthPA :: TyCon -> VM CoreExpr +buildLengthPA repr_tc + = do + arg <- newLocalVar FSLIT("xs") arg_ty + shape <- newLocalVar FSLIT("sel") shape_ty + body <- lengthPA (Var shape) + return . Lam arg + $ Case (Var arg) (mkWildId arg_ty) intPrimTy + [(DataAlt repr_dc, shape : map mkWildId repr_tys, body)] + where + arg_ty = mkTyConApp repr_tc . mkTyVarTys $ tyConTyVars repr_tc + [repr_dc] = tyConDataCons repr_tc + shape_ty : repr_tys = dataConRepArgTys repr_dc + + +-- data T = C0 t1 ... tm +-- ... +-- Ck u1 ... un +-- +-- data [:T:] = A ![:Int:] [:t1:] ... [:un:] +-- +-- replicatePA :: Int# -> T -> [:T:] +-- replicatePA n# t +-- = let c = case t of +-- C0 _ ... _ -> 0 +-- ... +-- Ck _ ... _ -> k +-- +-- xs1 = case t of +-- C0 x1 _ ... _ -> replicatePA @t1 n# x1 +-- _ -> emptyPA @t1 +-- +-- ... +-- +-- ysn = case t of +-- Ck _ ... _ yn -> replicatePA @un n# yn +-- _ -> emptyPA @un +-- in +-- A (replicatePA @Int n# c) xs1 ... ysn +-- +-- + +buildReplicatePA :: TyCon -> TyCon -> VM CoreExpr +buildReplicatePA vect_tc arr_tc + = do + len_var <- newLocalVar FSLIT("n") intPrimTy + val_var <- newLocalVar FSLIT("x") val_ty + + let len = Var len_var + val = Var val_var + + shape <- replicatePA len (ctr_num val) + reprs <- liftM concat $ mapM (mk_comp_arrs len val) vect_dcs + + return . mkLams [len_var, val_var] + $ mkConApp arr_dc (map (Type . TyVarTy) (tyConTyVars arr_tc) ++ (shape : reprs)) + where + val_ty = mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars arr_tc + wild = mkWildId val_ty + vect_dcs = tyConDataCons vect_tc + [arr_dc] = tyConDataCons arr_tc + + ctr_num val = Case val wild intTy (zipWith ctr_num_alt vect_dcs [0..]) + ctr_num_alt dc i = (DataAlt dc, map mkWildId (dataConRepArgTys dc), + mkConApp intDataCon [mkIntLitInt i]) + + + mk_comp_arrs len val dc = let tys = dataConRepArgTys dc + wilds = map mkWildId tys + in + sequence (zipWith3 (mk_comp_arr len val dc) + tys (inits wilds) (tails wilds)) + + mk_comp_arr len val dc ty pre (_:post) + = do + var <- newLocalVar FSLIT("x") ty + rep <- replicatePA len (Var var) + empty <- emptyPA ty + arr_ty <- mkPArrayType ty + + return $ Case val wild arr_ty + [(DataAlt dc, pre ++ (var : post), rep), (DEFAULT, [], empty)] + -- | 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: