-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
mkRepr, arrShapeTys, arrShapeVars, arrSelector,
module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
mkRepr, arrShapeTys, arrShapeVars, arrSelector,
| isFunTyCon tc = builtin closureTyCon
| isBoxedTupleTyCon tc = return tc
| isUnLiftedTyCon tc = return tc
| isFunTyCon tc = builtin closureTyCon
| isBoxedTupleTyCon tc = return tc
| isUnLiftedTyCon tc = return tc
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
-data PAInstance = PAInstance {
- painstDFun :: Var
- , painstOrigTyCon :: TyCon
- , painstVectTyCon :: TyCon
- , painstArrTyCon :: TyCon
- }
-
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
vectTypeEnv env
= do
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
vectTypeEnv env
= do
-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
}
= do
data_cons' <- mapM vectDataCon data_cons
zipWithM_ defDataCon data_cons data_cons'
return $ DataTyCon { data_cons = data_cons'
, is_enum = is_enum
}
- | 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)
, enum_arr_tycon = arr_tycon
, enum_arr_data_con = arr_data_con
}
, enum_arr_tycon = arr_tycon
, enum_arr_data_con = arr_data_con
}
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 :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr)
arrSelector (SumRepr {}) [len, sel, is] = return (len, sel, is)
arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is)
= liftM singleton $ emptyPA ty
emptyArrRepr (VoidRepr { void_tycon = tycon })
= liftM singleton $ emptyPA (mkTyConApp tycon [])
= liftM singleton $ emptyPA ty
emptyArrRepr (VoidRepr { void_tycon = tycon })
= liftM singleton $ emptyPA (mkTyConApp tycon [])
| otherwise = sumRepr =<< mapM unboxedProductRepr rep_tys
where
rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
| otherwise = sumRepr =<< mapM unboxedProductRepr rep_tys
where
rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
[(DataAlt con, vars, body)]
to_unboxed (ProdRepr { prod_components = tys
[(DataAlt con, vars, body)]
to_unboxed (ProdRepr { prod_components = tys
buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildFromPRepr repr vect_tc prepr_tc _
buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildFromPRepr repr vect_tc prepr_tc _
vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods)
bodies <- sequence . zipWith3 from_unboxed prods cons
$ map Var vars
vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods)
bodies <- sequence . zipWith3 from_unboxed prods cons
$ map Var vars
$ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
where
sum_alt data_con var body = (DataAlt data_con, [var], body)
$ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
where
sum_alt data_con var body = (DataAlt data_con, [var], body)
$ (DEFAULT, [], error_expr)
: zipWith mk_alt (tyConDataCons vect_tc) cons
$ (DEFAULT, [], error_expr)
: zipWith mk_alt (tyConDataCons vect_tc) cons
[(DataAlt data_con, [var], res)]
where
mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con)
[(DataAlt data_con, [var], res)]
where
mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con)
[(DataAlt data_con, vars, con `mkVarApps` vars)]
from_unboxed (IdRepr _) con expr
= return $ con `App` expr
[(DataAlt data_con, vars, con `mkVarApps` vars)]
from_unboxed (IdRepr _) con expr
= return $ con `App` expr
buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildToArrPRepr repr vect_tc prepr_tc arr_tc
= do
buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildToArrPRepr repr vect_tc prepr_tc arr_tc
= do
[(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
where
var_tys = mkTyVarTys $ tyConTyVars vect_tc
[(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
where
var_tys = mkTyVarTys $ tyConTyVars vect_tc
$ [(DataAlt data_con, shape_vars ++ vars, result)]
where
ty_args = map reprType prods
$ [(DataAlt data_con, shape_vars ++ vars, result)]
where
ty_args = map reprType prods
from_repr repr expr shape_vars [repr_vars] res_ty body
= from_prod repr expr shape_vars repr_vars res_ty body
from_repr repr expr shape_vars [repr_vars] res_ty body
= from_prod repr expr shape_vars repr_vars res_ty body
- from_prod prod@(ProdRepr { prod_components = tys
- , prod_arr_tycon = tycon
- , prod_arr_data_con = data_con })
+ from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr"
+
+ from_prod (ProdRepr { prod_components = tys
+ , prod_arr_tycon = tycon
+ , prod_arr_data_con = data_con })
[(DataAlt data_con, shape_vars ++ repr_vars, body)]
from_prod (EnumRepr { enum_arr_tycon = tycon
[(DataAlt data_con, shape_vars ++ repr_vars, body)]
from_prod (EnumRepr { enum_arr_tycon = tycon
dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
binds <- takeHoisted
return $ (dfun, dict) : binds
dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
binds <- takeHoisted
return $ (dfun, dict) : binds
orig_worker = dataConWorkId data_con
buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
orig_worker = dataConWorkId data_con
buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
var <- newLocalVar name (exprType body)
return (var, mkInlineMe body)
var <- newLocalVar name (exprType body)
return (var, mkInlineMe body)
paMethods = [(fsLit "toPRepr", buildToPRepr),
(fsLit "fromPRepr", buildFromPRepr),
(fsLit "toArrPRepr", buildToArrPRepr),
paMethods = [(fsLit "toPRepr", buildToPRepr),
(fsLit "fromPRepr", buildFromPRepr),
(fsLit "toArrPRepr", buildToArrPRepr),
classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
classifyTyCons = classify [] []
where
classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
classifyTyCons = classify [] []
where
classify conv keep cs ((tcs, ds) : rs)
| can_convert && must_convert
= classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
classify conv keep cs ((tcs, ds) : rs)
| can_convert && must_convert
= classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
-- | Compute mutually recursive groups of tycons in topological order
--
tyConGroups :: [TyCon] -> [TyConGroup]
-- | Compute mutually recursive groups of tycons in topological order
--
tyConGroups :: [TyCon] -> [TyConGroup]
where
edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
where
edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]