+ 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 paMethods
+ let meth_exprs = map (Var . fst) meth_binds
+
+ pa_dc <- builtin paDataCon
+ let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
+ body = Let (Rec meth_binds) dict
+ return . mkInlineMe $ abstract body
+ where
+ tvs = tyConTyVars arr_tc
+ arg_tys = mkTyVarTys tvs
+
+ mk_method (name, build)
+ = localV
+ $ do
+ body <- build vect_tc prepr_tc arr_tc
+ var <- newLocalVar name (exprType body)
+ return (var, mkInlineMe body)
+
+paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> VM CoreExpr)]
+paMethods = [(fsLit "toPRepr", buildToPRepr),
+ (fsLit "fromPRepr", buildFromPRepr),
+ (fsLit "toArrPRepr", buildToArrPRepr),
+ (fsLit "fromArrPRepr", buildFromArrPRepr),
+ (fsLit "dictPRepr", buildPRDict)]