+ 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 :: Shape -> TyCon -> TyCon -> Var -> VM CoreExpr
+buildPADict shape vect_tc arr_tc dfun
+ = polyAbstract tvs $ \abstract ->
+ do
+ meth_binds <- mapM (mk_method shape) 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 shape (name, build)
+ = localV
+ $ do
+ body <- build shape vect_tc arr_tc
+ var <- newLocalVar name (exprType body)
+ return (var, mkInlineMe body)
+
+paMethods = [(FSLIT("lengthPA"), buildLengthPA),
+ (FSLIT("replicatePA"), buildReplicatePA)]
+
+buildLengthPA :: Shape -> TyCon -> TyCon -> VM CoreExpr
+buildLengthPA shape vect_tc arr_tc
+ = do
+ parr_ty <- mkPArrayType (mkTyConApp vect_tc arg_tys)
+ arg <- newLocalVar FSLIT("xs") parr_ty
+ shapes <- mapM (newLocalVar FSLIT("sh")) shape_tys
+ wilds <- mapM newDummyVar repr_tys
+ let scrut = unwrapFamInstScrut arr_tc arg_tys (Var arg)
+ scrut_ty = exprType scrut