Commit 430cdcde authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au

Modify generation of PR dictionaries for new scheme

parent 395e4574
......@@ -26,7 +26,7 @@ import Var ( Var )
import Id ( mkWildId )
import Name ( Name, getOccName )
import NameEnv
import TysWiredIn ( unitTy, intTy, intDataCon, unitDataConId )
import TysWiredIn ( unitTy, unitTyCon, intTy, intDataCon, unitDataConId )
import TysPrim ( intPrimTy )
import Unique
......@@ -337,12 +337,36 @@ buildFromArrPRepr _ vect_tc prepr_tc arr_tc
= mkFromArrPRepr undefined undefined undefined undefined undefined undefined
buildPRDict :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildPRDict _ vect_tc prepr_tc _
= prCoerce prepr_tc var_tys
=<< prDictOfType (mkTyConApp prepr_tc var_tys)
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
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
Just sum_tycon = repr_sum_tycon
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
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 ->
do
......
......@@ -9,9 +9,9 @@ module VectUtils (
mkPADictType, mkPArrayType, mkPReprType,
parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut,
prDictOfType, prCoerce,
prDFunOfTyCon, prCoerce,
paDictArgType, paDictOfType, paDFunType,
paMethod, lengthPA, replicatePA, emptyPA, liftPA,
paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA,
polyAbstract, polyApply, polyVApply,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
......@@ -248,35 +248,9 @@ mkVScrut (ve, le)
(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
= do
dfun <- traceMaybeV "prDictOfType" (ppr tycon) (lookupTyConPR tycon)
prDFunApply (Var dfun) ty_args
prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
prDFunApply dfun tys
= do
args <- mapM mkDFunArg arg_tys
return $ mkApps mono_dfun args
where
mono_dfun = mkTyApps dfun tys
(arg_tys, _) = splitFunTys (exprType mono_dfun)
mkDFunArg :: Type -> VM CoreExpr
mkDFunArg ty
| Just (tycon, [arg]) <- splitTyConApp_maybe ty
= let name = tyConName tycon
get_dict | name == paTyConName = paDictOfType
| name == prTyConName = prDictOfType
| otherwise = pprPanic "mkDFunArg" (ppr ty)
in get_dict arg
mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty)
prDFunOfTyCon :: TyCon -> VM CoreExpr
prDFunOfTyCon tycon
= liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon))
prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
prCoerce repr_tc args expr
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment