-module VectType ( vectTyCon, vectType, vectTypeEnv,
- PAInstance, buildPADict )
-where
-#include "HsVersions.h"
+module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
+ mkRepr, arrShapeTys, arrShapeVars, arrSelector,
+ buildPADict,
+ fromVect )
+where
import VectMonad
import VectUtils
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 BasicTypes ( StrictnessMark(..), boolToRecFlag )
+import Var ( Var, TyVar )
import Id ( mkWildId )
import Name ( Name, getOccName )
import NameEnv
-import TysWiredIn ( unitTy, unitTyCon, intTy, intDataCon, unitDataConId )
+import TysWiredIn
import TysPrim ( intPrimTy )
import Unique
import UniqFM
import UniqSet
+import Util ( singleton )
import Digraph ( SCC(..), stronglyConnComp )
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 )
-- ----------------------------------------------------------------------------
-- FIXME: just for now
Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return 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 <- mkPArrayType vmono_ty
+ return (abstractType tyvars dicts vmono_ty,
+ abstractType tyvars dicts lmono_ty)
+ where
+ (tyvars, mono_ty) = splitForAllTys ty
+
+
vectType :: Type -> VM Type
vectType ty | Just ty' <- coreView ty = vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
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)
+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
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' ->
return $ DataTyCon { data_cons = data_cons'
, is_enum = is_enum
}
+vectAlgTyConRhs _ = panic "vectAlgTyConRhs"
vectDataCon :: DataCon -> VM DataCon
vectDataCon dc
where
tyvars = tyConTyVars vect_tc
-data TyConRepr = ProdRepr {
- repr_prod_arg_tys :: [Type]
- , repr_prod_tycon :: TyCon
- , repr_prod_data_con :: DataCon
- , repr_prod_arr_tycon :: TyCon
- , repr_prod_arr_data_con :: DataCon
- , repr_type :: Type
- }
- | SumRepr {
- repr_tys :: [[Type]]
- , repr_prod_tycons :: [Maybe TyCon]
- , repr_prod_data_cons :: [Maybe DataCon]
- , repr_prod_tys :: [Type]
- , repr_sum_tycon :: TyCon
- , repr_type :: Type
- }
-
-arrShapeTys :: TyConRepr -> VM [Type]
-arrShapeTys (ProdRepr {}) = return [intPrimTy]
-arrShapeTys (SumRepr {})
+
+data Repr = ProdRepr {
+ prod_components :: [Type]
+ , prod_tycon :: TyCon
+ , prod_data_con :: DataCon
+ , prod_arr_tycon :: TyCon
+ , prod_arr_data_con :: DataCon
+ }
+
+ | SumRepr {
+ sum_components :: [Repr]
+ , sum_tycon :: TyCon
+ , sum_arr_tycon :: TyCon
+ , sum_arr_data_con :: DataCon
+ }
+
+ | IdRepr Type
+
+ | VoidRepr {
+ void_tycon :: TyCon
+ , void_bottom :: CoreExpr
+ }
+
+ | EnumRepr {
+ enum_tycon :: TyCon
+ , enum_data_con :: DataCon
+ , enum_arr_tycon :: TyCon
+ , enum_arr_data_con :: DataCon
+ }
+
+voidRepr :: VM Repr
+voidRepr
= do
- uarr <- builtin uarrTyCon
- return [intPrimTy, mkTyConApp uarr [intTy]]
+ tycon <- builtin voidTyCon
+ var <- builtin voidVar
+ return $ VoidRepr {
+ void_tycon = tycon
+ , void_bottom = Var var
+ }
-arrReprTys :: TyConRepr -> VM [Type]
-arrReprTys (ProdRepr { repr_prod_arg_tys = tys })
- = mapM mkPArrayType tys
-arrReprTys (SumRepr { repr_tys = tys })
- = concat `liftM` mapM (mapM mkPArrayType) (map mk_prod tys)
- where
- mk_prod [] = [unitTy]
- mk_prod tys = tys
-
-
-mkTyConRepr :: TyCon -> VM TyConRepr
-mkTyConRepr vect_tc
- | is_product
- = let
- [prod_arg_tys] = repr_tys
- arity = length prod_arg_tys
- in
- do
- prod_tycon <- builtin (prodTyCon arity)
- let [prod_data_con] = tyConDataCons prod_tycon
+{-
+enumRepr :: VM Repr
+enumRepr
+ = do
+ tycon <- builtin enumerationTyCon
+ let [data_con] = tyConDataCons tycon
+ (arr_tycon, _) <- parrayReprTyCon (mkTyConApp tycon [])
+ let [arr_data_con] = tyConDataCons arr_tycon
- (arr_tycon, _) <- parrayReprTyCon
- . mkTyConApp prod_tycon
- $ replicate arity unitTy
+ return $ EnumRepr {
+ enum_tycon = tycon
+ , enum_data_con = data_con
+ , enum_arr_tycon = arr_tycon
+ , enum_arr_data_con = arr_data_con
+ }
+-}
+
+unboxedProductRepr :: [Type] -> VM Repr
+unboxedProductRepr [] = voidRepr
+unboxedProductRepr [ty] = return $ IdRepr ty
+unboxedProductRepr tys = boxedProductRepr tys
+
+boxedProductRepr :: [Type] -> VM Repr
+boxedProductRepr tys
+ = do
+ tycon <- builtin (prodTyCon arity)
+ let [data_con] = tyConDataCons tycon
+ tys' <- mapM boxType tys
+ (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys'
let [arr_data_con] = tyConDataCons arr_tycon
return $ ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_tycon = prod_tycon
- , repr_prod_data_con = prod_data_con
- , repr_prod_arr_tycon = arr_tycon
- , repr_prod_arr_data_con = arr_data_con
- , repr_type = mkTyConApp prod_tycon prod_arg_tys
+ prod_components = tys
+ , prod_tycon = tycon
+ , prod_data_con = data_con
+ , prod_arr_tycon = arr_tycon
+ , prod_arr_data_con = arr_data_con
}
+ where
+ arity = length tys
- | otherwise
+sumRepr :: [Repr] -> VM Repr
+sumRepr [] = voidRepr
+sumRepr [repr] = boxRepr repr
+sumRepr reprs
= do
- uarr <- builtin uarrTyCon
- prod_tycons <- mapM (mk_tycon prodTyCon) repr_tys
- let prod_tys = zipWith mk_tc_app_maybe prod_tycons repr_tys
- sum_tycon <- builtin (sumTyCon $ length repr_tys)
- arr_repr_tys <- mapM (mapM mkPArrayType . arr_repr_elem_tys) repr_tys
+ tycon <- builtin (sumTyCon arity)
+ (arr_tycon, _) <- parrayReprTyCon
+ . mkTyConApp tycon
+ $ map reprType reprs
+
+ let [arr_data_con] = tyConDataCons arr_tycon
return $ SumRepr {
- repr_tys = repr_tys
- , repr_prod_tycons = prod_tycons
- , repr_prod_data_cons = map (fmap mk_single_datacon) prod_tycons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = mkTyConApp sum_tycon prod_tys
+ sum_components = reprs
+ , sum_tycon = tycon
+ , sum_arr_tycon = arr_tycon
+ , sum_arr_data_con = arr_data_con
}
where
- tyvars = tyConTyVars vect_tc
- data_cons = tyConDataCons vect_tc
- repr_tys = map dataConRepArgTys data_cons
-
- is_product | [_] <- data_cons = True
- | otherwise = False
-
- mk_shape uarr = intPrimTy : mk_sel uarr
+ arity = length reprs
+
+splitSumRepr :: Repr -> [Repr]
+splitSumRepr (SumRepr { sum_components = reprs }) = reprs
+splitSumRepr repr = [repr]
+
+boxRepr :: Repr -> VM Repr
+boxRepr (VoidRepr {}) = boxedProductRepr []
+boxRepr (IdRepr ty) = boxedProductRepr [ty]
+boxRepr repr = return repr
+
+reprType :: Repr -> Type
+reprType (ProdRepr { prod_tycon = tycon, prod_components = tys })
+ = mkTyConApp tycon tys
+reprType (SumRepr { sum_tycon = tycon, sum_components = reprs })
+ = mkTyConApp tycon (map reprType reprs)
+reprType (IdRepr ty) = ty
+reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon []
+reprType (EnumRepr { enum_tycon = tycon }) = mkTyConApp tycon []
+
+arrReprType :: Repr -> VM Type
+arrReprType = mkPArrayType . reprType
+
+arrShapeTys :: Repr -> VM [Type]
+arrShapeTys (SumRepr {}) = sumShapeTys
+arrShapeTys (ProdRepr {}) = return [intPrimTy]
+arrShapeTys (IdRepr _) = return []
+arrShapeTys (VoidRepr {}) = return [intPrimTy]
+arrShapeTys (EnumRepr {}) = sumShapeTys
- mk_sel uarr | is_product = []
- | otherwise = [uarr_int, uarr_int]
- where
- uarr_int = mkTyConApp uarr [intTy]
+sumShapeTys :: VM [Type]
+sumShapeTys = do
+ int_arr <- builtin intPrimArrayTy
+ return [intPrimTy, int_arr, int_arr]
- mk_tycon get_tc tys
- | n > 1 = builtin (Just . get_tc n)
- | otherwise = return Nothing
- where n = length tys
- mk_single_datacon tc | [dc] <- tyConDataCons tc = dc
+arrShapeVars :: Repr -> VM [Var]
+arrShapeVars repr = mapM (newLocalVar (fsLit "sh")) =<< arrShapeTys repr
- mk_tc_app_maybe Nothing [] = unitTy
- mk_tc_app_maybe Nothing [ty] = ty
- mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys
+replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr]
+replicateShape (ProdRepr {}) len _ = return [len]
+replicateShape (SumRepr {}) len tag = replicateSumShape len tag
+replicateShape (IdRepr _) _ _ = return []
+replicateShape (VoidRepr {}) len _ = return [len]
+replicateShape (EnumRepr {}) len tag = replicateSumShape len tag
- arr_repr_elem_tys [] = [unitTy]
- arr_repr_elem_tys tys = tys
+replicateSumShape :: CoreExpr -> CoreExpr -> VM [CoreExpr]
+replicateSumShape len tag
+ = do
+ rep <- builtin replicatePAIntPrimVar
+ up <- builtin upToPAIntPrimVar
+ return [len, Var rep `mkApps` [len, tag], Var up `App` len]
+
+arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr)
+arrSelector (SumRepr {}) [len, sel, is] = return (len, sel, is)
+arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is)
+arrSelector _ _ = panic "arrSelector"
+
+emptyArrRepr :: Repr -> VM [CoreExpr]
+emptyArrRepr (SumRepr { sum_components = prods })
+ = liftM concat $ mapM emptyArrRepr prods
+emptyArrRepr (ProdRepr { prod_components = [] })
+ = return [Var unitDataConId]
+emptyArrRepr (ProdRepr { prod_components = tys })
+ = mapM emptyPA tys
+emptyArrRepr (IdRepr ty)
+ = liftM singleton $ emptyPA ty
+emptyArrRepr (VoidRepr { void_tycon = tycon })
+ = liftM singleton $ emptyPA (mkTyConApp tycon [])
+emptyArrRepr (EnumRepr {})
+ = return []
+
+arrReprTys :: Repr -> VM [Type]
+arrReprTys (SumRepr { sum_components = reprs })
+ = liftM concat $ mapM arrReprTys reprs
+arrReprTys (ProdRepr { prod_components = [] })
+ = return [unitTy]
+arrReprTys (ProdRepr { prod_components = tys })
+ = mapM mkPArrayType tys
+arrReprTys (IdRepr ty)
+ = liftM singleton $ mkPArrayType ty
+arrReprTys (VoidRepr { void_tycon = tycon })
+ = liftM singleton $ mkPArrayType (mkTyConApp tycon [])
+arrReprTys (EnumRepr {})
+ = return []
+
+arrReprTys' :: Repr -> VM [[Type]]
+arrReprTys' (SumRepr { sum_components = reprs })
+ = mapM arrReprTys reprs
+arrReprTys' repr = liftM singleton $ arrReprTys repr
+
+arrReprVars :: Repr -> VM [[Var]]
+arrReprVars repr
+ = mapM (mapM (newLocalVar (fsLit "rs"))) =<< arrReprTys' repr
+
+mkRepr :: TyCon -> VM Repr
+mkRepr vect_tc
+ | [tys] <- rep_tys = boxedProductRepr tys
+ -- | all null rep_tys = enumRepr
+ | otherwise = sumRepr =<< mapM unboxedProductRepr rep_tys
+ where
+ rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
buildPReprType :: TyCon -> VM Type
-buildPReprType = liftM repr_type . mkTyConRepr
-
-buildToPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToPRepr (ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_data_con = prod_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (newLocalVar FSLIT("x")) prod_arg_tys
+buildPReprType = liftM reprType . mkRepr
- return . Lam arg
- . wrapFamInstBody prepr_tc var_tys
- $ Case (Var arg) (mkWildId arg_ty) repr_type
- [(DataAlt data_con, vars,
- mkConApp prod_data_con (map Type prod_arg_tys ++ map Var vars))]
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- arg_ty = mkTyConApp vect_tc var_tys
- [data_con] = tyConDataCons vect_tc
-
-buildToPRepr (SumRepr {
- repr_tys = repr_tys
- , repr_prod_data_cons = prod_data_cons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
+buildToPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToPRepr repr vect_tc prepr_tc _
= do
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (mapM (newLocalVar FSLIT("x"))) repr_tys
+ arg <- newLocalVar (fsLit "x") arg_ty
+ result <- to_repr repr (Var arg)
return . Lam arg
. wrapFamInstBody prepr_tc var_tys
- . Case (Var arg) (mkWildId arg_ty) repr_type
- . zipWith4 mk_alt data_cons vars sum_data_cons
- . zipWith3 mk_prod prod_data_cons repr_tys $ map (map Var) vars
+ $ result
where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- arg_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
-
- sum_data_cons = tyConDataCons sum_tycon
-
- mk_alt dc vars sum_dc expr = (DataAlt dc, vars,
- mkConApp sum_dc (map Type prod_tys ++ [expr]))
-
- mk_prod _ _ [] = Var unitDataConId
- mk_prod _ _ [expr] = expr
- mk_prod (Just dc) tys exprs = mkConApp dc (map Type tys ++ exprs)
-
-buildFromPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromPRepr (ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_data_con = prod_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg_ty <- mkPReprType res_ty
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (newLocalVar FSLIT("x")) prod_arg_tys
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ arg_ty = mkTyConApp vect_tc var_tys
+ res_ty = reprType repr
- return . Lam arg
- $ Case (unwrapFamInstScrut prepr_tc var_tys (Var arg))
- (mkWildId repr_type)
- res_ty
- [(DataAlt prod_data_con, vars,
- mkConApp data_con (map Type var_tys ++ map Var vars))]
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- ty_args = map Type var_tys
- res_ty = mkTyConApp vect_tc var_tys
- [data_con] = tyConDataCons vect_tc
-
-buildFromPRepr (SumRepr {
- repr_tys = repr_tys
- , repr_prod_data_cons = prod_data_cons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
+ cons = tyConDataCons vect_tc
+ [con] = cons
+
+ to_repr (SumRepr { sum_components = prods
+ , sum_tycon = tycon })
+ expr
+ = do
+ (vars, bodies) <- mapAndUnzipM to_unboxed prods
+ return . Case expr (mkWildId (exprType expr)) res_ty
+ $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies
+ where
+ mk_alt con vars sum_con body
+ = (DataAlt con, vars, mkConApp sum_con (ty_args ++ [body]))
+
+ ty_args = map (Type . reprType) prods
+
+ to_repr (EnumRepr { enum_data_con = data_con }) expr
+ = return . Case expr (mkWildId (exprType expr)) res_ty
+ $ map mk_alt cons
+ where
+ mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con])
+
+ to_repr prod expr
+ = do
+ (vars, body) <- to_unboxed prod
+ return $ Case expr (mkWildId (exprType expr)) res_ty
+ [(DataAlt con, vars, body)]
+
+ to_unboxed (ProdRepr { prod_components = tys
+ , prod_data_con = data_con })
+ = do
+ vars <- mapM (newLocalVar (fsLit "r")) tys
+ return (vars, mkConApp data_con (map Type tys ++ map Var vars))
+
+ to_unboxed (IdRepr ty)
+ = do
+ var <- newLocalVar (fsLit "y") ty
+ return ([var], Var var)
+
+ to_unboxed (VoidRepr { void_bottom = bottom })
+ = return ([], bottom)
+
+ to_unboxed _ = panic "buildToPRepr/to_unboxed"
+
+
+buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromPRepr repr vect_tc prepr_tc _
= do
arg_ty <- mkPReprType res_ty
- arg <- newLocalVar FSLIT("x") arg_ty
-
- liftM (Lam arg
- . Case (unwrapFamInstScrut prepr_tc var_tys (Var arg))
- (mkWildId repr_type)
- res_ty
- . zipWith mk_alt sum_data_cons)
- (sequence
- $ zipWith4 un_prod data_cons prod_data_cons prod_tys repr_tys)
+ arg <- newLocalVar (fsLit "x") arg_ty
+
+ liftM (Lam arg)
+ . from_repr repr
+ $ unwrapFamInstScrut prepr_tc var_tys (Var arg)
where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- ty_args = map Type var_tys
- res_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ res_ty = mkTyConApp vect_tc var_tys
- sum_data_cons = tyConDataCons sum_tycon
+ cons = map (`mkConApp` map Type var_tys) (tyConDataCons vect_tc)
+ [con] = cons
- un_prod dc _ _ []
+ from_repr repr@(SumRepr { sum_components = prods
+ , sum_tycon = tycon })
+ expr
= do
- var <- newLocalVar FSLIT("u") unitTy
- return (var, mkConApp dc ty_args)
- un_prod dc _ _ [ty]
- = do
- var <- newLocalVar FSLIT("x") ty
- return (var, mkConApp dc (ty_args ++ [Var var]))
+ vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods)
+ bodies <- sequence . zipWith3 from_unboxed prods cons
+ $ map Var vars
+ return . Case expr (mkWildId (reprType repr)) res_ty
+ $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
+ where
+ sum_alt data_con var body = (DataAlt data_con, [var], body)
- un_prod dc (Just prod_dc) prod_ty tys
+ from_repr repr@(EnumRepr { enum_data_con = data_con }) expr
= do
- vars <- mapM (newLocalVar FSLIT("x")) tys
- pv <- newLocalVar FSLIT("p") prod_ty
+ var <- newLocalVar (fsLit "n") intPrimTy
- let res = mkConApp dc (ty_args ++ map Var vars)
- expr = Case (Var pv) (mkWildId prod_ty) res_ty
- [(DataAlt prod_dc, vars, res)]
+ let res = Case (Var var) (mkWildId intPrimTy) res_ty
+ $ (DEFAULT, [], error_expr)
+ : zipWith mk_alt (tyConDataCons vect_tc) cons
- return (pv, expr)
+ return $ Case expr (mkWildId (reprType repr)) res_ty
+ [(DataAlt data_con, [var], res)]
+ where
+ mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con)
- mk_alt sum_dc (var, expr) = (DataAlt sum_dc, [var], expr)
+ error_expr = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty
+ . showSDoc
+ $ sep [text "Invalid NDP representation of", ppr vect_tc]
+ from_repr repr expr = from_unboxed repr con expr
-buildToArrPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToArrPRepr repr@(ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_arr_tycon = prod_arr_tycon
- , repr_prod_arr_data_con = prod_arr_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc arr_tc
+ from_unboxed prod@(ProdRepr { prod_components = tys
+ , prod_data_con = data_con })
+ con
+ expr
+ = do
+ vars <- mapM (newLocalVar (fsLit "y")) tys
+ return $ Case expr (mkWildId (reprType prod)) res_ty
+ [(DataAlt data_con, vars, con `mkVarApps` vars)]
+
+ from_unboxed (IdRepr _) con expr
+ = return $ con `App` expr
+
+ from_unboxed (VoidRepr {}) con _
+ = return con
+
+ from_unboxed _ _ _ = panic "buildFromPRepr/from_unboxed"
+
+buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr repr vect_tc prepr_tc arr_tc
= do
arg_ty <- mkPArrayType el_ty
- shape_tys <- arrShapeTys repr
- arr_tys <- arrReprTys repr
- res_ty <- mkPArrayType repr_type
- rep_el_ty <- mkPReprType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
- arg <- newLocalVar FSLIT("xs") arg_ty
- shape_vars <- mapM (newLocalVar FSLIT("sh")) shape_tys
- rep_vars <- mapM (newLocalVar FSLIT("ys")) arr_tys
-
- let vars = shape_vars ++ rep_vars
+ res_ty <- mkPArrayType (reprType repr)
+
+ shape_vars <- arrShapeVars repr
+ repr_vars <- arrReprVars repr
parray_co <- mkBuiltinCo parrayTyCon
- let res = wrapFamInstBody prod_arr_tycon prod_arg_tys
- . mkConApp prod_arr_data_con
- $ map Type prod_arg_tys ++ map Var vars
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion parray_co
+ . mkSymCoercion
+ $ mkTyConApp repr_co var_tys
+
+ scrut = unwrapFamInstScrut arr_tc var_tys (Var arg)
- Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion parray_co
- . mkSymCoercion
- $ mkTyConApp repr_co var_tys
+ result <- to_repr shape_vars repr_vars repr
return . Lam arg
. mkCoerce co
- $ Case (unwrapFamInstScrut arr_tc var_tys (Var arg))
- (mkWildId (mkTyConApp arr_tc var_tys))
- res_ty
- [(DataAlt arr_dc, vars, res)]
+ $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty
+ [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
where
var_tys = mkTyVarTys $ tyConTyVars vect_tc
el_ty = mkTyConApp vect_tc var_tys
[arr_dc] = tyConDataCons arr_tc
+ to_repr shape_vars@(_ : _)
+ repr_vars
+ (SumRepr { sum_components = prods
+ , sum_arr_tycon = tycon
+ , sum_arr_data_con = data_con })
+ = do
+ exprs <- zipWithM to_prod repr_vars prods
-buildToArrPRepr _ _ _ _ = return (Var unitDataConId)
-{-
-buildToArrPRepr _ vect_tc prepr_tc arr_tc
- = do
- arg_ty <- mkPArrayType el_ty
- rep_tys <- mapM (mapM mkPArrayType) rep_el_tys
-
- 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
-
- let add_sel xs | has_selector = sel : xs
- | otherwise = xs
-
- all_bndrs = len : add_sel (concat bndrss)
-
- res <- parrayCoerce prepr_tc var_tys
- =<< mkToArrPRepr (Var len) (Var sel) (map (map Var) bndrss)
- res_ty <- mkPArrayType =<< mkPReprType el_ty
-
- 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)]
- 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
+ return . wrapFamInstBody tycon tys
+ . mkConApp data_con
+ $ map Type tys ++ map Var shape_vars ++ exprs
+ where
+ tys = map reprType prods
+
+ to_repr [len_var]
+ [repr_vars]
+ (ProdRepr { prod_components = tys
+ , prod_arr_tycon = tycon
+ , prod_arr_data_con = data_con })
+ = return . wrapFamInstBody tycon tys
+ . mkConApp data_con
+ $ map Type tys ++ map Var (len_var : repr_vars)
+
+ to_repr shape_vars
+ _
+ (EnumRepr { enum_arr_tycon = tycon
+ , enum_arr_data_con = data_con })
+ = return . wrapFamInstBody tycon []
+ . mkConApp data_con
+ $ map Var shape_vars
+
+ to_repr _ _ _ = panic "buildToArrPRepr/to_repr"
+
+ to_prod repr_vars@(r : _)
+ (ProdRepr { prod_components = tys@(ty : _)
+ , prod_arr_tycon = tycon
+ , prod_arr_data_con = data_con })
+ = do
+ len <- lengthPA ty (Var r)
+ return . wrapFamInstBody tycon tys
+ . mkConApp data_con
+ $ map Type tys ++ len : map Var repr_vars
- [arr_dc] = tyConDataCons arr_tc
+ to_prod [var] (IdRepr _) = return (Var var)
+ to_prod [var] (VoidRepr {}) = return (Var var)
+ to_prod _ _ = panic "buildToArrPRepr/to_prod"
- has_selector | [_] <- data_cons = False
- | otherwise = True
--}
-buildFromArrPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromArrPRepr repr@(ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_arr_tycon = prod_arr_tycon
- , repr_prod_arr_data_con = prod_arr_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc arr_tc
+buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromArrPRepr repr vect_tc prepr_tc arr_tc
= do
- rep_el_ty <- mkPReprType el_ty
- arg_ty <- mkPArrayType rep_el_ty
- shape_tys <- arrShapeTys repr
- arr_tys <- arrReprTys repr
- res_ty <- mkPArrayType el_ty
+ arg_ty <- mkPArrayType =<< mkPReprType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
- arg <- newLocalVar FSLIT("xs") arg_ty
- shape_vars <- mapM (newLocalVar FSLIT("sh")) shape_tys
- rep_vars <- mapM (newLocalVar FSLIT("ys")) arr_tys
+ res_ty <- mkPArrayType el_ty
- let vars = shape_vars ++ rep_vars
+ shape_vars <- arrShapeVars repr
+ repr_vars <- arrReprVars repr
parray_co <- mkBuiltinCo parrayTyCon
- let res = wrapFamInstBody arr_tc var_tys
- . mkConApp arr_dc
- $ map Type var_tys ++ map Var vars
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion parray_co
+ $ mkTyConApp repr_co var_tys
- Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion parray_co
- $ mkTyConApp repr_co var_tys
+ scrut = mkCoerce co (Var arg)
- scrut = unwrapFamInstScrut prod_arr_tycon prod_arg_tys
- $ mkCoerce co (Var arg)
+ result = wrapFamInstBody arr_tc var_tys
+ . mkConApp arr_dc
+ $ map Type var_tys ++ map Var (shape_vars ++ concat repr_vars)
- return . Lam arg
- $ Case (scrut)
- (mkWildId (mkTyConApp prod_arr_tycon prod_arg_tys))
- res_ty
- [(DataAlt prod_arr_data_con, vars, res)]
+ liftM (Lam arg)
+ (from_repr repr scrut shape_vars repr_vars res_ty result)
where
var_tys = mkTyVarTys $ tyConTyVars vect_tc
el_ty = mkTyConApp vect_tc var_tys
[arr_dc] = tyConDataCons arr_tc
-buildFromArrPRepr _ _ _ _ = return (Var unitDataConId)
-buildPRDictRepr :: TyConRepr -> VM CoreExpr
+ from_repr (SumRepr { sum_components = prods
+ , sum_arr_tycon = tycon
+ , sum_arr_data_con = data_con })
+ expr
+ shape_vars
+ repr_vars
+ res_ty
+ body
+ = do
+ vars <- mapM (newLocalVar (fsLit "xs")) =<< mapM arrReprType prods
+ result <- go prods repr_vars vars body
+
+ let scrut = unwrapFamInstScrut tycon ty_args expr
+ return . Case scrut (mkWildId scrut_ty) res_ty
+ $ [(DataAlt data_con, shape_vars ++ vars, result)]
+ where
+ ty_args = map reprType prods
+ scrut_ty = mkTyConApp tycon ty_args
+
+ go [] [] [] body = return body
+ go (prod : prods) (repr_vars : rss) (var : vars) body
+ = do
+ shape_vars <- mapM (newLocalVar (fsLit "s")) =<< arrShapeTys prod
+
+ from_prod prod (Var var) shape_vars repr_vars res_ty
+ =<< go prods rss vars body
+ go _ _ _ _ = panic "buildFromArrPRepr/go"
+
+ from_repr repr expr shape_vars [repr_vars] res_ty body
+ = from_prod repr expr shape_vars repr_vars res_ty body
+
+ from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr"
+
+ from_prod prod@(ProdRepr { prod_components = tys
+ , prod_arr_tycon = tycon
+ , prod_arr_data_con = data_con })
+ expr
+ shape_vars
+ repr_vars
+ res_ty
+ body
+ = do
+ let scrut = unwrapFamInstScrut tycon tys expr
+ scrut_ty = mkTyConApp tycon tys
+ _ty <- arrReprType prod
+
+ return $ Case scrut (mkWildId scrut_ty) res_ty
+ [(DataAlt data_con, shape_vars ++ repr_vars, body)]
+
+ from_prod (EnumRepr { enum_arr_tycon = tycon
+ , enum_arr_data_con = data_con })
+ expr
+ shape_vars
+ _
+ res_ty
+ body
+ = let scrut = unwrapFamInstScrut tycon [] expr
+ scrut_ty = mkTyConApp tycon []
+ in
+ return $ Case scrut (mkWildId scrut_ty) res_ty
+ [(DataAlt data_con, shape_vars, body)]
+
+ from_prod (IdRepr _)
+ expr
+ _shape_vars
+ [repr_var]
+ _res_ty
+ body
+ = return $ Let (NonRec repr_var expr) body
+
+ from_prod (VoidRepr {})
+ expr
+ _shape_vars
+ [repr_var]
+ _res_ty
+ body
+ = return $ Let (NonRec repr_var expr) body
+
+ from_prod _ _ _ _ _ _ = panic "buildFromArrPRepr/from_prod"
+
+buildPRDictRepr :: Repr -> VM CoreExpr
+buildPRDictRepr (VoidRepr { void_tycon = tycon })
+ = prDFunOfTyCon tycon
+buildPRDictRepr (IdRepr ty) = mkPR ty
buildPRDictRepr (ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_tycon = prod_tycon
+ prod_components = tys
+ , prod_tycon = tycon
})
= do
- prs <- mapM mkPR prod_arg_tys
- dfun <- prDFunOfTyCon prod_tycon
- return $ dfun `mkTyApps` prod_arg_tys `mkApps` prs
+ prs <- mapM mkPR tys
+ dfun <- prDFunOfTyCon tycon
+ return $ dfun `mkTyApps` tys `mkApps` prs
buildPRDictRepr (SumRepr {
- repr_tys = repr_tys
- , repr_prod_tycons = prod_tycons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- })
+ sum_components = prods
+ , sum_tycon = tycon })
= do
- prs <- mapM (mapM mkPR) repr_tys
- prod_prs <- sequence $ zipWith3 mk_prod_pr prod_tycons repr_tys prs
- sum_dfun <- prDFunOfTyCon sum_tycon
- return $ sum_dfun `mkTyApps` prod_tys `mkApps` prod_prs
- where
- mk_prod_pr _ _ [] = prDFunOfTyCon unitTyCon
- mk_prod_pr _ _ [pr] = return pr
- mk_prod_pr (Just tc) tys prs
- = do
- dfun <- prDFunOfTyCon tc
- return $ dfun `mkTyApps` tys `mkApps` prs
+ prs <- mapM buildPRDictRepr prods
+ dfun <- prDFunOfTyCon tycon
+ return $ dfun `mkTyApps` map reprType prods `mkApps` prs
+
+buildPRDictRepr (EnumRepr { enum_tycon = tycon })
+ = prDFunOfTyCon tycon
-buildPRDict :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildPRDict repr vect_tc prepr_tc _
= do
dict <- buildPRDictRepr repr
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
buildPArrayDataCon orig_name vect_tc repr_tc
= do
dc_name <- cloneName mkPArrayDataConOcc orig_name
- repr <- mkTyConRepr vect_tc
+ repr <- mkRepr vect_tc
shape_tys <- arrShapeTys repr
repr_tys <- arrReprTys repr
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
= do
- shape <- tyConShape vect_tc
- repr <- mkTyConRepr vect_tc
- sequence_ (zipWith4 (vectDataConWorker shape vect_tc arr_tc arr_dc)
- orig_dcs
- vect_dcs
- (inits repr_tys)
- (tails repr_tys))
+ repr <- mkRepr vect_tc
+ vectDataConWorkers repr orig_tc vect_tc arr_tc
dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
binds <- takeHoisted
return $ (dfun, dict) : binds
+
+vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon
+ -> VM ()
+vectDataConWorkers repr 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 reprs)
+ (tail $ tails reprs)
+ 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
+
+ rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
+ reprs = splitSumRepr repr
+
[arr_dc] = tyConDataCons arr_tc
- repr_tys = map dataConRepArgTys vect_dcs
+ mk_data_con con tys pre post
+ = liftM2 (,) (vect_data_con con)
+ (lift_data_con tys pre post (mkDataConTag con))
-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 :: TyConRepr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
-buildPADict repr vect_tc prepr_tc arr_tc dfun
+ vect_data_con con = return $ mkConApp con ty_args
+ lift_data_con tys pre_reprs post_reprs tag
+ = do
+ len <- builtin liftingContext
+ args <- mapM (newLocalVar (fsLit "xs"))
+ =<< mapM mkPArrayType tys
+
+ shape <- replicateShape repr (Var len) tag
+ repr <- mk_arr_repr (Var len) (map Var args)
+
+ pre <- liftM concat $ mapM emptyArrRepr pre_reprs
+ post <- liftM concat $ mapM emptyArrRepr post_reprs
+
+ return . mkLams (len : args)
+ . wrapFamInstBody arr_tc var_tys
+ . mkConApp arr_dc
+ $ ty_args ++ shape ++ pre ++ repr ++ post
+
+ mk_arr_repr len []
+ = do
+ units <- replicatePA len (Var unitDataConId)
+ return [units]
+
+ mk_arr_repr _ arrs = return arrs
+
+ 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 :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
+buildPADict repr vect_tc prepr_tc arr_tc _
= polyAbstract tvs $ \abstract ->
do
meth_binds <- mapM (mk_method repr) paMethods
body <- build repr 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)]
+
+paMethods :: [(FastString, Repr -> 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]
(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 applyClosureVar
+ 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
+
projects / ghc-hetmet.git / blobdiff