X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=958c5e6fd7a03c95b17c499da950ce1415f47853;hb=ee79af08084c320762b6b684e2ce8198395cf089;hp=5d03521889cff7e045455ca2dbbba302d88f1c2d;hpb=2e4068a25fb7b0905c264b51843e41fd328f0ed3;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 5d03521..958c5e6 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -4,14 +4,13 @@ module VectUtils ( mkDataConTag, splitClosureTy, - TyConRepr(..), mkTyConRepr, - mkToPRepr, mkToArrPRepr, mkFromPRepr, mkFromArrPRepr, + mkBuiltinCo, mkPADictType, mkPArrayType, mkPReprType, - parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut, - prDictOfType, prCoerce, + parrayReprTyCon, parrayReprDataCon, mkVScrut, + prDFunOfTyCon, paDictArgType, paDictOfType, paDFunType, - paMethod, lengthPA, replicatePA, emptyPA, liftPA, + paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA, polyAbstract, polyApply, polyVApply, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, buildClosure, buildClosures, @@ -37,6 +36,7 @@ import MkId ( unwrapFamInstScrut ) import Name ( Name ) import PrelNames import TysWiredIn +import TysPrim ( intPrimTy ) import BasicTypes ( Boxity(..) ) import Outputable @@ -68,7 +68,7 @@ isAnnTypeArg (_, AnnType t) = True isAnnTypeArg _ = False mkDataConTag :: DataCon -> CoreExpr -mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc] +mkDataConTag = mkIntLitInt . dataConTag splitUnTy :: String -> Name -> Type -> Type splitUnTy s name ty @@ -94,15 +94,20 @@ 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 splitPArrayTy :: Type -> Type splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName +splitPrimTyCon :: Type -> Maybe TyCon +splitPrimTyCon ty + | Just (tycon, []) <- splitTyConApp_maybe ty + , isPrimTyCon tycon + = Just tycon + + | otherwise = Nothing + mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type mkBuiltinTyConApp get_tc tys = do @@ -128,193 +133,6 @@ mkBuiltinTyConApps1 get_tc dft tys where mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] -data TyConRepr = TyConRepr { - repr_tyvars :: [TyVar] - , repr_tys :: [[Type]] - - , repr_embed_tys :: [[Type]] - , repr_prod_tycons :: [Maybe TyCon] - , repr_prod_tys :: [Type] - , repr_sum_tycon :: Maybe TyCon - , repr_type :: Type - } - -mkTyConRepr :: TyCon -> VM TyConRepr -mkTyConRepr vect_tc - = do - embed_tys <- mapM (mapM mkEmbedType) rep_tys - prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys - sum_tycon <- mk_tycon sumTyCon rep_tys - - let prod_tys = zipWith mk_tc_app_maybe prod_tycons embed_tys - - return $ TyConRepr { - repr_tyvars = tyvars - , repr_tys = rep_tys - - , repr_embed_tys = embed_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_tycon get_tc tys - | n > 1 = builtin (Just . get_tc n) - | otherwise = return Nothing - where n = length tys - - mk_tc_app_maybe Nothing [] = unitTy - mk_tc_app_maybe Nothing [ty] = ty - mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys - -{- -mkPRepr :: [[Type]] -> VM Type -mkPRepr tys - = do - embed_tc <- builtin embedTyCon - sum_tcs <- builtins sumTyCon - prod_tcs <- builtins prodTyCon - - let mk_sum [] = unitTy - mk_sum [ty] = ty - mk_sum tys = mkTyConApp (sum_tcs $ length tys) tys - - mk_prod [] = unitTy - mk_prod [ty] = ty - mk_prod tys = mkTyConApp (prod_tcs $ length tys) tys - - mk_embed ty = mkTyConApp embed_tc [ty] - - return . mk_sum - . map (mk_prod . map mk_embed) - $ tys --} - -mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type) -mkToPRepr ess - = do - embed_tc <- builtin embedTyCon - embed_dc <- builtin embedDataCon - sum_tcs <- builtins sumTyCon - prod_tcs <- builtins prodTyCon - - 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) - where - (exprs, tys) = unzip es - sum_tc = sum_tcs (length es) - mk_alt dc expr = mkConApp dc (map Type tys ++ [expr]) - - mk_prod [] = (Var unitDataConId, unitTy) - mk_prod [(expr, ty)] = (expr, ty) - mk_prod es = (mkConApp prod_dc (map Type tys ++ 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 - - return . mk_sum $ map (mk_prod . map mk_embed) ess - -mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr -mkToArrPRepr len sel ess - = do - embed_tc <- builtin embedTyCon - (embed_rtc, _) <- parrayReprTyCon (mkTyConApp embed_tc [unitTy]) - let [embed_rdc] = tyConDataCons embed_rtc - - 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 - - return (mkConApp sum_rdc (map Type tys ++ (len : sel : exprs)), - mkTyConApp sum_tc tys) - where - (exprs, tys) = unzip es - - mk_prod [(expr, ty)] = return (expr, ty) - mk_prod es - = do - prod_tc <- builtin . prodTyCon $ length es - (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys) - let [prod_rdc] = tyConDataCons prod_rtc - - return (mkConApp prod_rdc (map Type tys ++ (len : exprs)), - mkTyConApp prod_tc tys) - where - (exprs, tys) = unzip es - - mk_embed expr = (mkConApp embed_rdc [Type ty, expr], - mkTyConApp embed_tc [ty]) - where ty = splitPArrayTy (exprType expr) - - liftM fst (mk_sum =<< mapM (mk_prod . map mk_embed) 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 - - let un_sum expr ty [(vars, res)] = un_prod expr ty vars res - un_sum expr ty bs - = do - ps <- mapM (newLocalVar FSLIT("p")) tys - bodies <- sequence - $ zipWith4 un_prod (map Var ps) tys vars rs - return . Case expr (mkWildId ty) res_ty - $ zipWith3 mk_alt sum_dcs ps bodies - where - (vars, rs) = unzip bs - tys = splitFixedTyConApp sum_tc ty - sum_tc = sum_tcs $ length bs - sum_dcs = tyConDataCons sum_tc - - 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 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)] - 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) - -mkEmbedType :: Type -> VM Type -mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty] - mkClosureType :: Type -> Type -> VM Type mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty] @@ -328,18 +146,19 @@ mkPADictType :: Type -> VM Type mkPADictType ty = mkBuiltinTyConApp paTyCon [ty] mkPArrayType :: Type -> VM Type +mkPArrayType ty + | Just tycon <- splitPrimTyCon ty + = do + arr <- traceMaybeV "mkPArrayType" (ppr tycon) + $ lookupPrimPArray tycon + return $ mkTyConApp arr [] mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] -parrayCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr -parrayCoerce repr_tc args expr - | Just arg_co <- tyConFamilyCoercion_maybe repr_tc +mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion +mkBuiltinCo get_tc = do - parray <- builtin parrayTyCon - - let co = mkAppCoercion (mkTyConApp parray []) - (mkSymCoercion (mkTyConApp arg_co args)) - - return $ mkCoerce co expr + tc <- builtin get_tc + return $ mkTyConApp tc [] parrayReprTyCon :: Type -> VM (TyCon, [Type]) parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty]) @@ -357,46 +176,9 @@ mkVScrut (ve, le) (tc, arg_tys) <- parrayReprTyCon (exprType ve) return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys) -prDictOfType :: Type -> VM CoreExpr -prDictOfType orig_ty - | Just (tycon, ty_args) <- splitTyConApp_maybe orig_ty - = do - dfun <- traceMaybeV "prDictOfType" (ppr tycon) (lookupTyConPR tycon) - prDFunApply (Var dfun) ty_args - -prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr -prDFunApply dfun tys - = do - args <- mapM mkDFunArg arg_tys - return $ mkApps mono_dfun args - where - mono_dfun = mkTyApps dfun tys - (arg_tys, _) = splitFunTys (exprType mono_dfun) - -mkDFunArg :: Type -> VM CoreExpr -mkDFunArg ty - | Just (tycon, [arg]) <- splitTyConApp_maybe ty - - = let name = tyConName tycon - - get_dict | name == paTyConName = paDictOfType - | name == prTyConName = prDictOfType - | otherwise = pprPanic "mkDFunArg" (ppr ty) - - in get_dict arg - -mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty) - -prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr -prCoerce repr_tc args expr - | Just arg_co <- tyConFamilyCoercion_maybe repr_tc - = do - pr_tc <- builtin prTyCon - - let co = mkAppCoercion (mkTyConApp pr_tc []) - (mkSymCoercion (mkTyConApp arg_co args)) - - return $ mkCoerce co expr +prDFunOfTyCon :: TyCon -> VM CoreExpr +prDFunOfTyCon tycon + = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon)) paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) @@ -453,24 +235,44 @@ paDFunApply dfun tys dicts <- mapM paDictOfType tys return $ mkApps (mkTyApps dfun tys) dicts -paMethod :: (Builtins -> Var) -> Type -> VM CoreExpr -paMethod method ty +type PAMethod = (Builtins -> Var, String) + +pa_length = (lengthPAVar, "lengthPA") +pa_replicate = (replicatePAVar, "replicatePA") +pa_empty = (emptyPAVar, "emptyPA") + +paMethod :: PAMethod -> Type -> VM CoreExpr +paMethod (method, name) ty + | Just tycon <- splitPrimTyCon ty + = do + fn <- traceMaybeV "paMethod" (ppr tycon <+> text name) + $ lookupPrimMethod tycon name + return (Var fn) + +paMethod (method, name) ty = do fn <- builtin method dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] +mkPR :: Type -> VM CoreExpr +mkPR ty + = do + fn <- builtin mkPRVar + dict <- paDictOfType ty + return $ mkApps (Var fn) [Type ty, dict] + lengthPA :: CoreExpr -> VM CoreExpr -lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty) +lengthPA x = liftM (`App` x) (paMethod pa_length ty) where ty = splitPArrayTy (exprType x) replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr replicatePA len x = liftM (`mkApps` [len,x]) - (paMethod replicatePAVar (exprType x)) + (paMethod pa_replicate (exprType x)) emptyPA :: Type -> VM CoreExpr -emptyPA = paMethod emptyPAVar +emptyPA = paMethod pa_empty liftPA :: CoreExpr -> VM CoreExpr liftPA x