bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc
return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs))
+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
+
buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
do
paMethods = [(FSLIT("lengthPA"), buildLengthPA),
(FSLIT("replicatePA"), buildReplicatePA),
(FSLIT("toPRepr"), buildToPRepr),
- (FSLIT("fromPRepr"), buildFromPRepr)]
+ (FSLIT("fromPRepr"), buildFromPRepr),
+ (FSLIT("dictPRepr"), buildPRDict)]
buildLengthPA :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildLengthPA shape vect_tc _ arr_tc
mkPRepr, mkToPRepr, mkFromPRepr,
mkPADictType, mkPArrayType, mkPReprType,
parrayReprTyCon, parrayReprDataCon, mkVScrut,
- prDictOfType,
+ prDictOfType, prCoerce,
paDictArgType, paDictOfType, paDFunType,
paMethod, lengthPA, replicatePA, emptyPA, liftPA,
polyAbstract, polyApply, polyVApply,
import DsUtils
import CoreSyn
import CoreUtils
+import Coercion
import Type
import TypeRep
import TyCon
(tc, arg_tys) <- parrayReprTyCon (exprType ve)
return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys)
-
prDictOfType :: Type -> VM CoreExpr
prDictOfType orig_ty
| Just (tycon, ty_args) <- splitTyConApp_maybe orig_ty
mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty)
+prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
+prCoerce repr_tc args expr
+ | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
+ = do
+ pr_tc <- builtin prTyCon
+
+ let co = mkAppCoercion (mkTyConApp pr_tc [])
+ (mkSymCoercion (mkTyConApp arg_co args))
+
+ return $ mkCoerce co expr
+
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
where