-{-# 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,
import Var ( Var, TyVar )
import Id ( mkWildId )
import Name ( Name, getOccName )
import Var ( Var, TyVar )
import Id ( mkWildId )
import Name ( Name, getOccName )
-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
, 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 [])
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 _
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
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_prod prod@(ProdRepr { prod_components = tys
, prod_arr_tycon = tycon
, prod_arr_data_con = data_con })
return $ Case scrut (mkWildId scrut_ty) res_ty
[(DataAlt data_con, shape_vars ++ repr_vars, body)]
return $ Case scrut (mkWildId scrut_ty) res_ty
[(DataAlt data_con, shape_vars ++ repr_vars, body)]
return $ Case scrut (mkWildId scrut_ty) res_ty
[(DataAlt data_con, shape_vars, body)]
return $ Case scrut (mkWildId scrut_ty) res_ty
[(DataAlt data_con, shape_vars, body)]
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