import Id ( mkWildId )
import Name ( Name, getOccName )
import NameEnv
-import TysWiredIn ( unitTy, intTy, intDataCon )
+import TysWiredIn ( unitTy, unitTyCon, intTy, intDataCon, unitDataConId )
import TysPrim ( intPrimTy )
import Unique
buildPReprType :: TyCon -> VM Type
buildPReprType = liftM repr_type . mkTyConRepr
-buildToPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToPRepr _ vect_tc prepr_tc _
+buildToPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToPRepr (TyConRepr {
+ repr_tys = repr_tys
+ , repr_prod_data_cons = prod_data_cons
+ , repr_prod_tys = prod_tys
+ , repr_sum_data_cons = sum_data_cons
+ , repr_type = repr_type
+ })
+ vect_tc prepr_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
+ arg <- newLocalVar FSLIT("x") arg_ty
+ vars <- mapM (mapM (newLocalVar FSLIT("x"))) repr_tys
return . Lam arg
. wrapFamInstBody prepr_tc var_tys
- . Case (Var arg) (mkWildId arg_ty) res_ty
- $ zipWith3 mk_alt data_cons bndrss alt_bodies
+ . Case (Var arg) (mkWildId arg_ty) repr_type
+ . mk_alts data_cons vars
+ . zipWith3 mk_prod prod_data_cons repr_tys $ map (map Var) vars
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
- mk_alt data_con bndrs body = (DataAlt data_con, bndrs, body)
+ mk_alts _ _ [] = [(DEFAULT, [], Var unitDataConId)]
+ mk_alts [dc] [vars] [expr] = [(DataAlt dc, vars, expr)]
+ mk_alts dcs vars exprs = zipWith4 mk_alt dcs vars sum_data_cons exprs
+
+ 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 (TyConRepr {
+ repr_tys = repr_tys
+ , repr_prod_data_cons = prod_data_cons
+ , repr_prod_tys = prod_tys
+ , repr_sum_data_cons = sum_data_cons
+ , repr_type = repr_type
+ })
+ vect_tc prepr_tc _
+ = do
+ arg_ty <- mkPReprType res_ty
+ arg <- newLocalVar FSLIT("x") arg_ty
+
+ liftM (Lam arg
+ . un_sum (unwrapFamInstScrut prepr_tc var_tys (Var arg)))
+ (sequence
+ $ zipWith4 un_prod data_cons prod_data_cons prod_tys repr_tys)
+ 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
+
+ un_prod dc _ _ []
+ = 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]))
+
+ un_prod dc (Just prod_dc) prod_ty tys
+ = do
+ vars <- mapM (newLocalVar FSLIT("x")) tys
+ pv <- newLocalVar FSLIT("p") prod_ty
+
+ let res = mkConApp dc (ty_args ++ map Var vars)
+ expr = Case (Var pv) (mkWildId prod_ty) res_ty
+ [(DataAlt prod_dc, vars, res)]
+
+ return (pv, expr)
+
+ un_sum scrut [(var, expr)] = Let (NonRec var scrut) expr
+ un_sum scrut alts
+ = Case scrut (mkWildId repr_type) res_ty
+ $ zipWith mk_alt sum_data_cons alts
+
+ mk_alt sum_dc (var, expr) = (DataAlt sum_dc, [var], expr)
+
-buildToArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildToArrPRepr _ vect_tc prepr_tc arr_tc
= do
arg_ty <- mkPArrayType el_ty
has_selector | [_] <- data_cons = False
| otherwise = True
+buildFromArrPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromArrPRepr _ vect_tc prepr_tc arr_tc
+ = mkFromArrPRepr undefined undefined undefined undefined undefined undefined
-buildFromPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromPRepr _ vect_tc prepr_tc _
+buildPRDict :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict (TyConRepr {
+ repr_tys = repr_tys
+ , repr_prod_tycons = prod_tycons
+ , repr_prod_tys = prod_tys
+ , repr_sum_tycon = repr_sum_tycon
+ })
+ 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
+ prs <- mapM (mapM mkPR) repr_tys
+ prod_prs <- sequence $ zipWith3 mk_prod_pr prod_tycons repr_tys prs
+ sum_pr <- mk_sum_pr prod_prs
+ prCoerce prepr_tc var_tys sum_pr
where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- res_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
- mk_alt dc = do
- bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc
- return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs))
+ Just sum_tycon = repr_sum_tycon
-buildFromArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromArrPRepr _ vect_tc prepr_tc arr_tc
- = mkFromArrPRepr undefined undefined undefined undefined undefined undefined
+ 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
-buildPRDict :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildPRDict _ vect_tc prepr_tc _
- = prCoerce prepr_tc var_tys
- =<< prDictOfType (mkTyConApp prepr_tc var_tys)
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ mk_sum_pr [pr] = return pr
+ mk_sum_pr prs
+ = do
+ dfun <- prDFunOfTyCon sum_tycon
+ return $ dfun `mkTyApps` prod_tys `mkApps` prs
buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
buildPArrayDataCon orig_name vect_tc repr_tc
= do
dc_name <- cloneName mkPArrayDataConOcc orig_name
- shape <- tyConShape vect_tc
- repr_tys <- mapM mkPArrayType types
+ repr <- mkTyConRepr vect_tc
+
+ let all_tys = arr_shape_tys repr ++ concat (arr_repr_tys repr)
liftDs $ buildDataCon dc_name
False -- not infix
- (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
+ (map (const NotMarkedStrict) all_tys)
[] -- no field labels
(tyConTyVars vect_tc)
[] -- no existentials
[] -- no eq spec
[] -- no context
- (shapeReprTys shape ++ repr_tys)
+ all_tys
repr_tc
- where
- types = [ty | dc <- tyConDataCons vect_tc
- , ty <- dataConRepArgTys dc]
mkPADFun :: TyCon -> VM Var
mkPADFun vect_tc
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))
- dict <- buildPADict shape vect_tc prepr_tc arr_tc dfun
+ dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
binds <- takeHoisted
return $ (dfun, dict) : binds
where
++ map Var args
++ empty_post
-buildPADict :: Shape -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
-buildPADict shape vect_tc prepr_tc arr_tc dfun
+buildPADict :: TyConRepr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
+buildPADict repr vect_tc prepr_tc arr_tc dfun
= polyAbstract tvs $ \abstract ->
do
- meth_binds <- mapM (mk_method shape) paMethods
+ meth_binds <- mapM (mk_method repr) 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 repr (name, build)
= localV
$ do
- body <- build shape vect_tc prepr_tc arr_tc
+ body <- build repr vect_tc prepr_tc arr_tc
var <- newLocalVar name (exprType body)
return (var, mkInlineMe body)
projects / ghc-hetmet.git / blobdiff