X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=c7336efbc58514c01999e79115a88dc308a621a7;hb=724425265ded8958a719b3a62f43006674b506c8;hp=0f101bd3cb11134be62a94e00728f2bff3288fba;hpb=a52f14894e48d47e62b5b33f7d7f4b3f2cc88a79;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 0f101bd..c7336ef 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -3,9 +3,12 @@ module VectUtils ( collectAnnValBinders, mkDataConTag, splitClosureTy, - mkPRepr, mkToPRepr, mkFromPRepr, + + TyConRepr(..), mkTyConRepr, + mkToArrPRepr, mkFromPRepr, mkFromArrPRepr, mkPADictType, mkPArrayType, mkPReprType, - parrayReprTyCon, parrayReprDataCon, mkVScrut, + + parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut, prDictOfType, prCoerce, paDictArgType, paDictOfType, paDFunType, paMethod, lengthPA, replicatePA, emptyPA, liftPA, @@ -27,7 +30,7 @@ import Coercion import Type import TypeRep import TyCon -import DataCon ( DataCon, dataConWrapId, dataConTag ) +import DataCon import Var import Id ( mkWildId ) import MkId ( unwrapFamInstScrut ) @@ -91,9 +94,6 @@ splitFixedTyConApp tc ty | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty) -splitEmbedTy :: Type -> Type -splitEmbedTy = splitUnTy "splitEmbedTy" embedTyConName - splitClosureTy :: Type -> (Type, Type) splitClosureTy = splitBinTy "splitClosureTy" closureTyConName @@ -125,63 +125,78 @@ mkBuiltinTyConApps1 get_tc dft tys where mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] -mkPRepr :: [[Type]] -> VM Type -mkPRepr tys - = do - embed_tc <- builtin embedTyCon - sum_tcs <- builtins sumTyCon - prod_tcs <- builtins prodTyCon +data TyConRepr = TyConRepr { + repr_tyvars :: [TyVar] + , repr_tys :: [[Type]] - let mk_sum [] = unitTy - mk_sum [ty] = ty - mk_sum tys = mkTyConApp (sum_tcs $ length tys) tys + , repr_prod_tycons :: [Maybe TyCon] + , repr_prod_tys :: [Type] + , repr_sum_tycon :: Maybe TyCon + , repr_type :: Type + } - mk_prod [] = unitTy - mk_prod [ty] = ty - mk_prod tys = mkTyConApp (prod_tcs $ length tys) tys +mkTyConRepr :: TyCon -> VM TyConRepr +mkTyConRepr vect_tc + = do + prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys + let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys + sum_tycon <- mk_tycon sumTyCon prod_tys + + return $ TyConRepr { + repr_tyvars = tyvars + , repr_tys = rep_tys + + , repr_prod_tycons = prod_tycons + , repr_prod_tys = prod_tys + , repr_sum_tycon = sum_tycon + , repr_type = mk_tc_app_maybe sum_tycon prod_tys + } + where + tyvars = tyConTyVars vect_tc + data_cons = tyConDataCons vect_tc + rep_tys = map dataConRepArgTys data_cons - mk_embed ty = mkTyConApp embed_tc [ty] + mk_tycon get_tc tys + | n > 1 = builtin (Just . get_tc n) + | otherwise = return Nothing + where n = length tys - return . mk_sum - . map (mk_prod . map mk_embed) - $ tys + mk_tc_app_maybe Nothing [] = unitTy + mk_tc_app_maybe Nothing [ty] = ty + mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys -mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type) -mkToPRepr ess +mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr +mkToArrPRepr len sel ess = do - embed_tc <- builtin embedTyCon - embed_dc <- builtin embedDataCon - sum_tcs <- builtins sumTyCon - prod_tcs <- builtins prodTyCon + let mk_sum [(expr, ty)] = return (expr, ty) + mk_sum es + = do + sum_tc <- builtin . sumTyCon $ length es + (sum_rtc, _) <- parrayReprTyCon (mkTyConApp sum_tc tys) + let [sum_rdc] = tyConDataCons sum_rtc - let mk_sum [] = ([Var unitDataConId], unitTy) - mk_sum [(expr, ty)] = ([expr], ty) - mk_sum es = (zipWith mk_alt (tyConDataCons sum_tc) exprs, - mkTyConApp sum_tc tys) + return (mkConApp sum_rdc (map Type tys ++ (len : sel : exprs)), + mkTyConApp sum_tc tys) where - (exprs, tys) = unzip es - sum_tc = sum_tcs (length es) - mk_alt dc expr = mkConApp dc (map Type tys ++ [expr]) + (exprs, tys) = unzip es + + mk_prod [expr] = return (expr, splitPArrayTy (exprType expr)) + mk_prod exprs + = do + prod_tc <- builtin . prodTyCon $ length exprs + (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys) + let [prod_rdc] = tyConDataCons prod_rtc - mk_prod [] = (Var unitDataConId, unitTy) - mk_prod [(expr, ty)] = (expr, ty) - mk_prod es = (mkConApp prod_dc (map Type tys ++ exprs), + return (mkConApp prod_rdc (map Type tys ++ (len : exprs)), mkTyConApp prod_tc tys) where - (exprs, tys) = unzip es - prod_tc = prod_tcs (length es) - [prod_dc] = tyConDataCons prod_tc - - mk_embed expr = (mkConApp embed_dc [Type ty, expr], - mkTyConApp embed_tc [ty]) - where ty = exprType expr + tys = map (splitPArrayTy . exprType) exprs - return . mk_sum $ map (mk_prod . map mk_embed) ess + liftM fst (mk_sum =<< mapM mk_prod ess) mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr mkFromPRepr scrut res_ty alts = do - embed_dc <- builtin embedDataCon sum_tcs <- builtins sumTyCon prod_tcs <- builtins prodTyCon @@ -202,25 +217,21 @@ mkFromPRepr scrut res_ty alts mk_alt dc p body = (DataAlt dc, [p], body) un_prod expr ty [] r = return r - un_prod expr ty [var] r = return $ un_embed expr ty var r + un_prod expr ty [var] r = return $ Let (NonRec var expr) r un_prod expr ty vars r - = do - xs <- mapM (newLocalVar FSLIT("x")) tys - let body = foldr (\(e,t,v) r -> un_embed e t v r) r - $ zip3 (map Var xs) tys vars - return $ Case expr (mkWildId ty) res_ty - [(DataAlt prod_dc, xs, body)] + = return $ Case expr (mkWildId ty) res_ty + [(DataAlt prod_dc, vars, r)] where - tys = splitFixedTyConApp prod_tc ty prod_tc = prod_tcs $ length vars [prod_dc] = tyConDataCons prod_tc - un_embed expr ty var r - = Case expr (mkWildId ty) res_ty - [(DataAlt embed_dc, [var], r)] - un_sum scrut (exprType scrut) alts +mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr + -> VM CoreExpr +mkFromArrPRepr scrut res_ty len sel vars res + = return (Var unitDataConId) + mkClosureType :: Type -> Type -> VM Type mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty] @@ -236,6 +247,17 @@ mkPADictType ty = mkBuiltinTyConApp paTyCon [ty] mkPArrayType :: Type -> VM Type mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] +parrayCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr +parrayCoerce repr_tc args expr + | Just arg_co <- tyConFamilyCoercion_maybe repr_tc + = do + parray <- builtin parrayTyCon + + let co = mkAppCoercion (mkTyConApp parray []) + (mkSymCoercion (mkTyConApp arg_co args)) + + return $ mkCoerce co expr + parrayReprTyCon :: Type -> VM (TyCon, [Type]) parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty]) @@ -355,6 +377,9 @@ paMethod method ty dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] +mkPR :: Type -> VM CoreExpr +mkPR = paMethod mkPRVar + lengthPA :: CoreExpr -> VM CoreExpr lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty) where