-module VectType ( vectTyCon, vectType, vectTypeEnv,
- PAInstance, buildPADict )
+module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
+ -- arrSumArity, pdataCompTys, pdataCompVars,
+ buildPADict,
+ fromVect )
where
-#include "HsVersions.h"
-
import VectMonad
import VectUtils
import VectCore
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import CoreSyn
import CoreUtils
+import MkCore ( mkWildCase )
import BuildTyCl
import DataCon
import TyCon
import TypeRep
import Coercion
import FamInstEnv ( FamInst, mkLocalFamInst )
-import InstEnv ( Instance, mkLocalInstance, instanceDFunId )
import OccName
import MkId
-import BasicTypes ( StrictnessMark(..), OverlapFlag(..), boolToRecFlag )
-import Var ( Var )
-import Id ( mkWildId )
+import BasicTypes ( StrictnessMark(..), boolToRecFlag )
+import Var ( Var, TyVar )
import Name ( Name, getOccName )
import NameEnv
-import TysWiredIn ( unitTy, intTy, intDataCon )
-import TysPrim ( intPrimTy )
import Unique
import UniqFM
import UniqSet
-import Digraph ( SCC(..), stronglyConnComp )
+import Util
+import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices )
import Outputable
+import FastString
-import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_ )
+import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
import Data.List ( inits, tails, zipWith4, zipWith5 )
-- ----------------------------------------------------------------------------
| isFunTyCon tc = builtin closureTyCon
| isBoxedTupleTyCon tc = return tc
| isUnLiftedTyCon tc = return tc
- | otherwise = do
- r <- lookupTyCon tc
- case r of
- Just tc' -> return tc'
+ | otherwise = maybeCantVectoriseM "Tycon not vectorised:" (ppr tc)
+ $ lookupTyCon tc
+
+vectAndLiftType :: Type -> VM (Type, Type)
+vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
+vectAndLiftType ty
+ = do
+ mdicts <- mapM paDictArgType tyvars
+ let dicts = [dict | Just dict <- mdicts]
+ vmono_ty <- vectType mono_ty
+ lmono_ty <- mkPDataType vmono_ty
+ return (abstractType tyvars dicts vmono_ty,
+ abstractType tyvars dicts lmono_ty)
+ where
+ (tyvars, mono_ty) = splitForAllTys ty
- -- FIXME: just for now
- Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
vectType :: Type -> VM Type
vectType ty | Just ty' <- coreView ty = vectType ty'
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
- (mapM vectType [ty1,ty2])
+ (mapM vectAndBoxType [ty1,ty2])
vectType ty@(ForAllTy _ _)
= do
mdicts <- mapM paDictArgType tyvars
mono_ty' <- vectType mono_ty
- return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
+ return $ abstractType tyvars [dict | Just dict <- mdicts] mono_ty'
where
(tyvars, mono_ty) = splitForAllTys ty
-vectType ty = pprPanic "vectType:" (ppr ty)
+vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
+
+vectAndBoxType :: Type -> VM Type
+vectAndBoxType ty = vectType ty >>= boxType
+
+abstractType :: [TyVar] -> [Type] -> Type -> Type
+abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts
+
+-- ----------------------------------------------------------------------------
+-- Boxing
+
+boxType :: Type -> VM Type
+boxType ty
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isUnLiftedTyCon tycon
+ = do
+ r <- lookupBoxedTyCon tycon
+ case r of
+ Just tycon' -> return $ mkTyConApp tycon' []
+ Nothing -> return ty
+boxType ty = return ty
-- ----------------------------------------------------------------------------
-- Type definitions
type TyConGroup = ([TyCon], UniqSet TyCon)
-data PAInstance = PAInstance {
- painstDFun :: Var
- , painstOrigTyCon :: TyCon
- , painstVectTyCon :: TyCon
- , painstArrTyCon :: TyCon
- }
-
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
vectTypeEnv env
= do
new_tcs <- vectTyConDecls conv_tcs
let orig_tcs = keep_tcs ++ conv_tcs
- vect_tcs = keep_tcs ++ new_tcs
+ vect_tcs = keep_tcs ++ new_tcs
- repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs
- parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
- dfuns <- mapM mkPADFun vect_tcs
+ repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs
+ pdata_tcs <- zipWithM buildPDataTyCon orig_tcs vect_tcs
+ dfuns <- mapM mkPADFun vect_tcs
defTyConPAs (zip vect_tcs dfuns)
binds <- sequence (zipWith5 buildTyConBindings orig_tcs
vect_tcs
repr_tcs
- parr_tcs
+ pdata_tcs
dfuns)
- let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs
+ let all_new_tcs = new_tcs ++ repr_tcs ++ pdata_tcs
let new_env = extendTypeEnvList env
(map ATyCon all_new_tcs
++ [ADataCon dc | tc <- all_new_tcs
, dc <- tyConDataCons tc])
- return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds)
+ return (new_env, map mkLocalFamInst (repr_tcs ++ pdata_tcs), concat binds)
where
tycons = typeEnvTyCons env
groups = tyConGroups tycons
mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
- keep_tc tc = let dcs = tyConDataCons tc
- in
- defTyCon tc tc >> zipWithM_ defDataCon dcs dcs
-
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
- mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
+ mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
- where
- lazy_zip [] _ = []
- lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
vectTyConDecl :: TyCon -> VM TyCon
vectTyConDecl tc
= do
name' <- cloneName mkVectTyConOcc name
- rhs' <- vectAlgTyConRhs (algTyConRhs tc)
+ rhs' <- vectAlgTyConRhs tc (algTyConRhs tc)
liftDs $ buildAlgTyCon name'
tyvars
tyvars = tyConTyVars tc
rec_flag = boolToRecFlag (isRecursiveTyCon tc)
-vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
-vectAlgTyConRhs (DataTyCon { data_cons = data_cons
- , is_enum = is_enum
- })
+vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
+vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
+ , is_enum = is_enum
+ })
= do
data_cons' <- mapM vectDataCon data_cons
zipWithM_ defDataCon data_cons data_cons'
return $ DataTyCon { data_cons = data_cons'
, is_enum = is_enum
}
+vectAlgTyConRhs tc _ = cantVectorise "Can't vectorise type definition:" (ppr tc)
vectDataCon :: DataCon -> VM DataCon
vectDataCon dc
- | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
- | not . null $ dataConEqSpec dc = pprPanic "vectDataCon: eq spec" (ppr dc)
+ | not . null $ dataConExTyVars dc
+ = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
+ | not . null $ dataConEqSpec dc
+ = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
| otherwise
= do
name' <- cloneName mkVectDataConOcc name
[] -- no existential tvs for now
[] -- no eq spec for now
[] -- no context
- arg_tys
+ arg_tys
+ (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs))
tycon'
where
name = dataConName dc
liftDs $ buildSynTyCon name
tyvars
(SynonymTyCon rhs_ty)
+ (typeKind rhs_ty)
(Just $ mk_fam_inst prepr_tc vect_tc)
where
tyvars = tyConTyVars vect_tc
buildPReprType :: TyCon -> VM Type
-buildPReprType = mkPRepr . map dataConRepArgTys . tyConDataCons
-
-buildToPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToPRepr _ vect_tc prepr_tc _
+buildPReprType vect_tc = sum_type . map dataConRepArgTys $ tyConDataCons vect_tc
+ where
+ sum_type [] = voidType
+ sum_type [tys] = prod_type tys
+ sum_type _ = do
+ (sum_tc, _, _, args) <- reprSumTyCons vect_tc
+ return $ mkTyConApp sum_tc args
+
+ prod_type [] = voidType
+ prod_type [ty] = return ty
+ prod_type tys = do
+ prod_tc <- builtin (prodTyCon (length tys))
+ return $ mkTyConApp prod_tc tys
+
+reprSumTyCons :: TyCon -> VM (TyCon, TyCon, Type, [Type])
+reprSumTyCons vect_tc
= do
- arg <- newLocalVar FSLIT("x") arg_ty
- bndrss <- mapM (mapM (newLocalVar FSLIT("x"))) rep_tys
- (alt_bodies, res_ty) <- mkToPRepr $ map (map Var) bndrss
+ tc <- builtin (sumTyCon arity)
+ args <- mapM (prod . dataConRepArgTys) cons
+ (pdata_tc, _) <- pdataReprTyCon (mkTyConApp tc args)
+ sel_ty <- builtin (selTy arity)
+ return (tc, pdata_tc, sel_ty, args)
+ where
+ cons = tyConDataCons vect_tc
+ arity = length cons
- return . Lam arg
- . wrapFamInstBody prepr_tc var_tys
- . Case (Var arg) (mkWildId arg_ty) res_ty
- $ zipWith3 mk_alt data_cons bndrss alt_bodies
+ prod [] = voidType
+ prod [ty] = return ty
+ prod tys = do
+ prod_tc <- builtin (prodTyCon (length tys))
+ return $ mkTyConApp prod_tc tys
+
+buildToPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToPRepr vect_tc repr_tc _
+ = do
+ let arg_ty = mkTyConApp vect_tc ty_args
+ res_ty <- mkPReprType arg_ty
+ arg <- newLocalVar (fsLit "x") arg_ty
+ result <- to_sum (Var arg) arg_ty res_ty (tyConDataCons vect_tc)
+ return $ Lam arg result
where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- arg_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
- rep_tys = map dataConRepArgTys data_cons
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
- mk_alt data_con bndrs body = (DataAlt data_con, bndrs, body)
+ wrap = wrapFamInstBody repr_tc ty_args
+
+ to_sum _ _ _ []
+ = do
+ void <- builtin voidVar
+ return $ wrap (Var void)
-buildToArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToArrPRepr _ vect_tc prepr_tc arr_tc
+ to_sum arg arg_ty res_ty [con]
+ = do
+ (prod, vars) <- to_prod (dataConRepArgTys con)
+ return $ mkWildCase arg arg_ty res_ty
+ [(DataAlt con, vars, wrap prod)]
+
+ to_sum arg arg_ty res_ty cons
+ = do
+ (prods, vars) <- mapAndUnzipM (to_prod . dataConRepArgTys) cons
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ let sum_cons = [mkConApp con (map Type sum_ty_args)
+ | con <- tyConDataCons sum_tc]
+ return . mkWildCase arg arg_ty res_ty
+ $ zipWith4 mk_alt cons vars sum_cons prods
+ where
+ mk_alt con vars sum_con expr
+ = (DataAlt con, vars, wrap $ sum_con `App` expr)
+
+ to_prod []
+ = do
+ void <- builtin voidVar
+ return (Var void, [])
+ to_prod [ty]
+ = do
+ var <- newLocalVar (fsLit "x") ty
+ return (Var var, [var])
+ to_prod tys
+ = do
+ prod_con <- builtin (prodDataCon (length tys))
+ vars <- newLocalVars (fsLit "x") tys
+ return (mkConApp prod_con (map Type tys ++ map Var vars), vars)
+
+buildFromPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromPRepr vect_tc repr_tc _
= do
- arg_ty <- mkPArrayType el_ty
- rep_tys <- mapM (mapM mkPArrayType) rep_el_tys
+ arg_ty <- mkPReprType res_ty
+ arg <- newLocalVar (fsLit "x") arg_ty
- arg <- newLocalVar FSLIT("xs") arg_ty
- bndrss <- mapM (mapM (newLocalVar FSLIT("ys"))) rep_tys
- len <- newLocalVar FSLIT("len") intPrimTy
- sel <- newLocalVar FSLIT("sel") =<< mkPArrayType intTy
+ result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
+ (tyConDataCons vect_tc)
+ return $ Lam arg result
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ res_ty = mkTyConApp vect_tc ty_args
- let add_sel xs | has_selector = sel : xs
- | otherwise = xs
+ from_sum _ [] = pprPanic "buildFromPRepr" (ppr vect_tc)
+ from_sum expr [con] = from_prod expr con
+ from_sum expr cons
+ = do
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ let sum_cons = tyConDataCons sum_tc
+ vars <- newLocalVars (fsLit "x") sum_ty_args
+ prods <- zipWithM from_prod (map Var vars) cons
+ return . mkWildCase expr (exprType expr) res_ty
+ $ zipWith3 mk_alt sum_cons vars prods
+ where
+ mk_alt con var expr = (DataAlt con, [var], expr)
+
+ from_prod expr con
+ = case dataConRepArgTys con of
+ [] -> return $ apply_con []
+ [_] -> return $ apply_con [expr]
+ tys -> do
+ prod_con <- builtin (prodDataCon (length tys))
+ vars <- newLocalVars (fsLit "y") tys
+ return $ mkWildCase expr (exprType expr) res_ty
+ [(DataAlt prod_con, vars, apply_con (map Var vars))]
+ where
+ apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs
- all_bndrs = len : add_sel (concat bndrss)
+buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr vect_tc prepr_tc pdata_tc
+ = do
+ arg_ty <- mkPDataType el_ty
+ res_ty <- mkPDataType =<< mkPReprType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
- res <- parrayCoerce prepr_tc var_tys
- =<< mkToArrPRepr (Var len) (Var sel) (map (map Var) bndrss)
- res_ty <- mkPArrayType =<< mkPReprType el_ty
+ pdata_co <- mkBuiltinCo pdataTyCon
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion pdata_co
+ . mkSymCoercion
+ $ mkTyConApp repr_co ty_args
+
+ scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
+
+ (vars, result) <- to_sum (tyConDataCons vect_tc)
return . Lam arg
- $ Case (unwrapFamInstScrut arr_tc var_tys (Var arg))
- (mkWildId (mkTyConApp arr_tc var_tys))
- res_ty
- [(DataAlt arr_dc, all_bndrs, res)]
+ $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
+ [(DataAlt pdata_dc, vars, mkCoerce co result)]
where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- el_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
- rep_el_tys = map dataConRepArgTys data_cons
+ ty_args = mkTyVarTys $ tyConTyVars vect_tc
+ el_ty = mkTyConApp vect_tc ty_args
+
+ [pdata_dc] = tyConDataCons pdata_tc
+
+ to_sum [] = do
+ pvoid <- builtin pvoidVar
+ return ([], Var pvoid)
+ to_sum [con] = to_prod con
+ to_sum cons = do
+ (vars, exprs) <- mapAndUnzipM to_prod cons
+ (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
+ sel <- newLocalVar (fsLit "sel") sel_ty
+ let [pdata_con] = tyConDataCons pdata_tc
+ result = wrapFamInstBody pdata_tc arg_tys
+ . mkConApp pdata_con
+ $ map Type arg_tys ++ (Var sel : exprs)
+ return (sel : concat vars, result)
+
+ to_prod con
+ | [] <- tys = do
+ pvoid <- builtin pvoidVar
+ return ([], Var pvoid)
+ | [ty] <- tys = do
+ var <- newLocalVar (fsLit "x") ty
+ return ([var], Var var)
+ | otherwise
+ = do
+ vars <- newLocalVars (fsLit "x") tys
+ prod_tc <- builtin (prodTyCon (length tys))
+ (pdata_prod_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
+ let [pdata_prod_con] = tyConDataCons pdata_prod_tc
+ result = wrapFamInstBody pdata_prod_tc tys
+ . mkConApp pdata_prod_con
+ $ map Type tys ++ map Var vars
+ return (vars, result)
+ where
+ tys = dataConRepArgTys con
- [arr_dc] = tyConDataCons arr_tc
+buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromArrPRepr vect_tc prepr_tc pdata_tc
+ = do
+ arg_ty <- mkPDataType =<< mkPReprType el_ty
+ res_ty <- mkPDataType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
- has_selector | [_] <- data_cons = False
- | otherwise = True
+ pdata_co <- mkBuiltinCo pdataTyCon
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion pdata_co
+ $ mkTyConApp repr_co var_tys
+ scrut = mkCoerce co (Var arg)
-buildFromPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromPRepr _ vect_tc prepr_tc _
- = do
- arg_ty <- mkPReprType res_ty
- arg <- newLocalVar FSLIT("x") arg_ty
- alts <- mapM mk_alt data_cons
- body <- mkFromPRepr (unwrapFamInstScrut prepr_tc var_tys (Var arg))
- res_ty alts
- return $ Lam arg body
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- res_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
-
- mk_alt dc = do
- bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc
- return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs))
-
-buildFromArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromArrPRepr _ vect_tc prepr_tc arr_tc
- = mkFromArrPRepr undefined undefined undefined undefined undefined undefined
-
-buildPRDict :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildPRDict _ vect_tc prepr_tc _
- = prCoerce prepr_tc var_tys
- =<< prDictOfType (mkTyConApp prepr_tc var_tys)
+ (args, mk) <- from_sum res_ty scrut (tyConDataCons vect_tc)
+
+ let result = wrapFamInstBody pdata_tc var_tys
+ . mkConApp pdata_dc
+ $ map Type var_tys ++ args
+
+ return $ Lam arg (mk result)
where
var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ el_ty = mkTyConApp vect_tc var_tys
+
+ [pdata_dc] = tyConDataCons pdata_tc
+
+ from_sum res_ty expr [] = return ([], mk)
+ where
+ mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)]
+ from_sum res_ty expr [con] = from_prod res_ty expr con
+ from_sum res_ty expr cons
+ = do
+ (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
+ sel <- newLocalVar (fsLit "sel") sel_ty
+ vars <- newLocalVars (fsLit "xs") arg_tys
+ rs <- zipWithM (from_prod res_ty) (map Var vars) cons
+ let (prods, mks) = unzip rs
+ [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc arg_tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, sel : vars, foldr ($) body mks)]
+ return (Var sel : concat prods, mk)
+
+
+ from_prod res_ty expr con
+ | [] <- tys = return ([], id)
+ | [_] <- tys = return ([expr], id)
+ | otherwise
+ = do
+ prod_tc <- builtin (prodTyCon (length tys))
+ (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
+ pdata_tys <- mapM mkPDataType tys
+ vars <- newLocalVars (fsLit "ys") pdata_tys
+ let [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, vars, body)]
+
+ return (map Var vars, mk)
+ where
+ tys = dataConRepArgTys con
-buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
-buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
+buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict vect_tc prepr_tc _
+ = do
+ dict <- sum_dict (tyConDataCons vect_tc)
+ pr_co <- mkBuiltinCo prTyCon
+ let co = mkAppCoercion pr_co
+ . mkSymCoercion
+ $ mkTyConApp arg_co ty_args
+ return (mkCoerce co dict)
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ Just arg_co = tyConFamilyCoercion_maybe prepr_tc
+
+ sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon
+ sum_dict [con] = prod_dict con
+ sum_dict cons = do
+ dicts <- mapM prod_dict cons
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ dfun <- prDFunOfTyCon sum_tc
+ return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts
+
+ prod_dict con
+ | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon
+ | [ty] <- tys = mkPR ty
+ | otherwise = do
+ dicts <- mapM mkPR tys
+ prod_tc <- builtin (prodTyCon (length tys))
+ dfun <- prDFunOfTyCon prod_tc
+ return $ dfun `mkTyApps` tys `mkApps` dicts
+ where
+ tys = dataConRepArgTys con
+
+buildPDataTyCon :: TyCon -> TyCon -> VM TyCon
+buildPDataTyCon orig_tc vect_tc = fixV $ \repr_tc ->
do
- name' <- cloneName mkPArrayTyConOcc orig_name
- rhs <- buildPArrayTyConRhs orig_name vect_tc repr_tc
- parray <- builtin parrayTyCon
+ name' <- cloneName mkPDataTyConOcc orig_name
+ rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc
+ pdata <- builtin pdataTyCon
liftDs $ buildAlgTyCon name'
tyvars
rec_flag -- FIXME: is this ok?
False -- FIXME: no generics
False -- not GADT syntax
- (Just $ mk_fam_inst parray vect_tc)
+ (Just $ mk_fam_inst pdata vect_tc)
where
orig_name = tyConName orig_tc
tyvars = tyConTyVars vect_tc
rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
-
-buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
-buildPArrayTyConRhs orig_name vect_tc repr_tc
+
+buildPDataTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
+buildPDataTyConRhs orig_name vect_tc repr_tc
= do
- data_con <- buildPArrayDataCon orig_name vect_tc repr_tc
+ data_con <- buildPDataDataCon orig_name vect_tc repr_tc
return $ DataTyCon { data_cons = [data_con], is_enum = False }
-buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
-buildPArrayDataCon orig_name vect_tc repr_tc
+buildPDataDataCon :: Name -> TyCon -> TyCon -> VM DataCon
+buildPDataDataCon orig_name vect_tc repr_tc
= do
- dc_name <- cloneName mkPArrayDataConOcc orig_name
- shape <- tyConShape vect_tc
- repr_tys <- mapM mkPArrayType types
+ dc_name <- cloneName mkPDataDataConOcc orig_name
+ comp_tys <- components
liftDs $ buildDataCon dc_name
False -- not infix
- (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
+ (map (const NotMarkedStrict) comp_tys)
[] -- no field labels
- (tyConTyVars vect_tc)
+ tvs
[] -- no existentials
[] -- no eq spec
[] -- no context
- (shapeReprTys shape ++ repr_tys)
+ comp_tys
+ (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
repr_tc
where
- types = [ty | dc <- tyConDataCons vect_tc
- , ty <- dataConRepArgTys dc]
+ tvs = tyConTyVars vect_tc
+ cons = tyConDataCons vect_tc
+ arity = length cons
+
+ components
+ | arity > 1 = liftM2 (:) (builtin (selTy arity)) data_components
+ | otherwise = data_components
+
+ data_components = mapM mkPDataType
+ . concat
+ $ map dataConRepArgTys cons
mkPADFun :: TyCon -> VM Var
mkPADFun vect_tc
= newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
-data Shape = Shape {
- shapeReprTys :: [Type]
- , shapeStrictness :: [StrictnessMark]
- , shapeLength :: [CoreExpr] -> VM CoreExpr
- , shapeReplicate :: CoreExpr -> CoreExpr -> VM [CoreExpr]
- }
-
-tyConShape :: TyCon -> VM Shape
-tyConShape vect_tc
- | isProductTyCon vect_tc
- = return $ Shape {
- shapeReprTys = [intPrimTy]
- , shapeStrictness = [NotMarkedStrict]
- , shapeLength = \[len] -> return len
- , shapeReplicate = \len _ -> return [len]
- }
-
- | otherwise
- = do
- repr_ty <- mkPArrayType intTy -- FIXME: we want to unbox this
- return $ Shape {
- shapeReprTys = [repr_ty]
- , shapeStrictness = [MarkedStrict]
- , shapeLength = \[sel] -> lengthPA sel
- , shapeReplicate = \len n -> do
- e <- replicatePA len n
- return [e]
- }
-
buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
-> VM [(Var, CoreExpr)]
-buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun
+buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc dfun
= do
- shape <- tyConShape vect_tc
- sequence_ (zipWith4 (vectDataConWorker shape vect_tc arr_tc arr_dc)
- orig_dcs
- vect_dcs
- (inits repr_tys)
- (tails repr_tys))
- dict <- buildPADict shape vect_tc prepr_tc arr_tc dfun
+ vectDataConWorkers orig_tc vect_tc pdata_tc
+ dict <- buildPADict vect_tc prepr_tc pdata_tc dfun
binds <- takeHoisted
return $ (dfun, dict) : binds
+
+vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
+vectDataConWorkers orig_tc vect_tc arr_tc
+ = do
+ bs <- sequence
+ . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys
+ $ zipWith4 mk_data_con (tyConDataCons vect_tc)
+ rep_tys
+ (inits rep_tys)
+ (tail $ tails rep_tys)
+ mapM_ (uncurry hoistBinding) bs
where
- orig_dcs = tyConDataCons orig_tc
- vect_dcs = tyConDataCons vect_tc
+ tyvars = tyConTyVars vect_tc
+ var_tys = mkTyVarTys tyvars
+ ty_args = map Type var_tys
+ res_ty = mkTyConApp vect_tc var_tys
+
+ cons = tyConDataCons vect_tc
+ arity = length cons
[arr_dc] = tyConDataCons arr_tc
- repr_tys = map dataConRepArgTys vect_dcs
+ rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
-vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon
- -> DataCon -> DataCon -> [[Type]] -> [[Type]]
- -> VM ()
-vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post)
- = do
- clo <- closedV
- . inBind orig_worker
- . polyAbstract tvs $ \abstract ->
- liftM (abstract . vectorised)
- $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift)
-
- worker <- cloneId mkVectOcc orig_worker (exprType clo)
- hoistBinding worker clo
- defGlobalVar orig_worker worker
- return ()
- where
- tvs = tyConTyVars vect_tc
- arg_tys = mkTyVarTys tvs
- res_ty = mkTyConApp vect_tc arg_tys
-
- orig_worker = dataConWorkId orig_dc
-
- mk_vect = return . mkConApp vect_dc $ map Type arg_tys
- mk_lift = do
- len <- newLocalVar FSLIT("n") intPrimTy
- arr_tys <- mapM mkPArrayType dc_tys
- args <- mapM (newLocalVar FSLIT("xs")) arr_tys
- shapes <- shapeReplicate shape
- (Var len)
- (mkDataConTag vect_dc)
-
- empty_pre <- mapM emptyPA (concat pre)
- empty_post <- mapM emptyPA (concat post)
-
- return . mkLams (len : args)
- . wrapFamInstBody arr_tc arg_tys
- . mkConApp arr_dc
- $ map Type arg_tys ++ shapes
- ++ empty_pre
- ++ map Var args
- ++ empty_post
-
-buildPADict :: Shape -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
-buildPADict shape vect_tc prepr_tc arr_tc dfun
+
+ mk_data_con con tys pre post
+ = liftM2 (,) (vect_data_con con)
+ (lift_data_con tys pre post (mkDataConTag con))
+
+ sel_replicate len tag
+ | arity > 1 = do
+ rep <- builtin (selReplicate arity)
+ return [rep `mkApps` [len, tag]]
+
+ | otherwise = return []
+
+ vect_data_con con = return $ mkConApp con ty_args
+ lift_data_con tys pre_tys post_tys tag
+ = do
+ len <- builtin liftingContext
+ args <- mapM (newLocalVar (fsLit "xs"))
+ =<< mapM mkPDataType tys
+
+ sel <- sel_replicate (Var len) tag
+
+ pre <- mapM emptyPD (concat pre_tys)
+ post <- mapM emptyPD (concat post_tys)
+
+ return . mkLams (len : args)
+ . wrapFamInstBody arr_tc var_tys
+ . mkConApp arr_dc
+ $ ty_args ++ sel ++ pre ++ map Var args ++ post
+
+ def_worker data_con arg_tys mk_body
+ = do
+ body <- closedV
+ . inBind orig_worker
+ . polyAbstract tyvars $ \abstract ->
+ liftM (abstract . vectorised)
+ $ buildClosures tyvars [] arg_tys res_ty mk_body
+
+ vect_worker <- cloneId mkVectOcc orig_worker (exprType body)
+ defGlobalVar orig_worker vect_worker
+ return (vect_worker, body)
+ where
+ orig_worker = dataConWorkId data_con
+
+buildPADict :: TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
+buildPADict vect_tc prepr_tc arr_tc _
= polyAbstract tvs $ \abstract ->
do
- meth_binds <- mapM (mk_method shape) paMethods
+ meth_binds <- mapM mk_method paMethods
let meth_exprs = map (Var . fst) meth_binds
pa_dc <- builtin paDataCon
tvs = tyConTyVars arr_tc
arg_tys = mkTyVarTys tvs
- mk_method shape (name, build)
+ mk_method (name, build)
= localV
$ do
- body <- build shape vect_tc prepr_tc arr_tc
+ body <- build vect_tc prepr_tc arr_tc
var <- newLocalVar name (exprType body)
return (var, mkInlineMe body)
-
-paMethods = [(FSLIT("toPRepr"), buildToPRepr),
- (FSLIT("fromPRepr"), buildFromPRepr),
- (FSLIT("toArrPRepr"), buildToArrPRepr),
- (FSLIT("fromArrPRepr"), buildFromArrPRepr),
- (FSLIT("dictPRepr"), buildPRDict)]
-
-buildLengthPA :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildLengthPA shape vect_tc _ arr_tc
- = do
- parr_ty <- mkPArrayType (mkTyConApp vect_tc arg_tys)
- arg <- newLocalVar FSLIT("xs") parr_ty
- shapes <- mapM (newLocalVar FSLIT("sh")) shape_tys
- wilds <- mapM newDummyVar repr_tys
- let scrut = unwrapFamInstScrut arr_tc arg_tys (Var arg)
- scrut_ty = exprType scrut
- body <- shapeLength shape (map Var shapes)
-
- return . Lam arg
- $ Case scrut (mkWildId scrut_ty) intPrimTy
- [(DataAlt repr_dc, shapes ++ wilds, body)]
- where
- arg_tys = mkTyVarTys $ tyConTyVars arr_tc
- [repr_dc] = tyConDataCons arr_tc
-
- shape_tys = shapeReprTys shape
- repr_tys = drop (length shape_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 :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildReplicatePA shape 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_reprs <- shapeReplicate shape len (ctr_num val)
- reprs <- liftM concat $ mapM (mk_comp_arrs len val) vect_dcs
-
- return . mkLams [len_var, val_var]
- . wrapFamInstBody arr_tc arg_tys
- $ mkConApp arr_dc (map Type arg_tys ++ shape_reprs ++ reprs)
- where
- arg_tys = mkTyVarTys (tyConTyVars arr_tc)
- val_ty = mkTyConApp vect_tc arg_tys
- 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
- [(DEFAULT, [], empty), (DataAlt dc, pre ++ (var : post), rep)]
+paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> VM CoreExpr)]
+paMethods = [(fsLit "toPRepr", buildToPRepr),
+ (fsLit "fromPRepr", buildFromPRepr),
+ (fsLit "toArrPRepr", buildToArrPRepr),
+ (fsLit "fromArrPRepr", buildFromArrPRepr),
+ (fsLit "dictPRepr", buildPRDict)]
-- | 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 cs [] = (conv, keep)
+ 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
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 (stronglyConnComp edges)
+tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
where
edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
(tcs, dss) = unzip els
tyConsOfTyCon :: TyCon -> UniqSet TyCon
-tyConsOfTyCon
+tyConsOfTyCon
= tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
tyConsOfType :: Type -> UniqSet TyCon
tyConsOfType ty
| Just ty' <- coreView ty = tyConsOfType ty'
-tyConsOfType (TyVarTy v) = emptyUniqSet
+tyConsOfType (TyVarTy _) = emptyUniqSet
tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
where
extend | isUnLiftedTyCon tc
tyConsOfTypes :: [Type] -> UniqSet TyCon
tyConsOfTypes = unionManyUniqSets . map tyConsOfType
+
+-- ----------------------------------------------------------------------------
+-- Conversions
+
+fromVect :: Type -> CoreExpr -> VM CoreExpr
+fromVect ty expr | Just ty' <- coreView ty = fromVect ty' expr
+fromVect (FunTy arg_ty res_ty) expr
+ = do
+ arg <- newLocalVar (fsLit "x") arg_ty
+ varg <- toVect arg_ty (Var arg)
+ varg_ty <- vectType arg_ty
+ vres_ty <- vectType res_ty
+ apply <- builtin applyVar
+ body <- fromVect res_ty
+ $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
+ return $ Lam arg body
+fromVect ty expr
+ = identityConv ty >> return expr
+
+toVect :: Type -> CoreExpr -> VM CoreExpr
+toVect ty expr = identityConv ty >> return expr
+
+identityConv :: Type -> VM ()
+identityConv ty | Just ty' <- coreView ty = identityConv ty'
+identityConv (TyConApp tycon tys)
+ = do
+ mapM_ identityConv tys
+ identityConvTyCon tycon
+identityConv _ = noV
+
+identityConvTyCon :: TyCon -> VM ()
+identityConvTyCon tc
+ | isBoxedTupleTyCon tc = return ()
+ | isUnLiftedTyCon tc = return ()
+ | otherwise = do
+ tc' <- maybeV (lookupTyCon tc)
+ if tc == tc' then return () else noV
+