+prDictOfType :: Type -> VM CoreExpr
+prDictOfType ty = prDictOfTyApp ty_fn ty_args
+ where
+ (ty_fn, ty_args) = splitAppTys ty
+
+prDictOfTyApp :: Type -> [Type] -> VM CoreExpr
+prDictOfTyApp ty_fn ty_args
+ | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
+prDictOfTyApp (TyConApp tc _) ty_args
+ = do
+ dfun <- liftM Var $ maybeV (lookupTyConPR tc)
+ prDFunApply dfun ty_args
+prDictOfTyApp _ _ = noV
+
+prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+ = do
+ dicts <- mapM prDictOfType tys
+ return $ mkApps (mkTyApps dfun tys) dicts
+
+wrapPR :: Type -> VM CoreExpr
+wrapPR ty
+ = do
+ pa_dict <- paDictOfType ty
+ pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon
+ return $ mkApps pr_dfun [Type ty, pa_dict]
+
+replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr
+replicatePD len x = liftM (`mkApps` [len,x])
+ (paMethod replicatePDVar "replicatePD" (exprType x))
+
+emptyPD :: Type -> VM CoreExpr
+emptyPD = paMethod emptyPDVar "emptyPD"
+
+packPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr
+packPD ty xs len sel = liftM (`mkApps` [xs, len, sel])
+ (paMethod packPDVar "packPD" ty)
+
+packByTagPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+ -> VM CoreExpr
+packByTagPD ty xs len tags t
+ = liftM (`mkApps` [xs, len, tags, t])
+ (paMethod packByTagPDVar "packByTagPD" ty)
+
+combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr]
+ -> VM CoreExpr
+combinePD ty len sel xs
+ = liftM (`mkApps` (len : sel : xs))
+ (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty)