From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Thu, 23 Aug 2007 03:20:48 +0000 (+0000)
Subject: Generate dictPRepr
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ea8027bad72931bce05f36cae99497e7f255eef7

Generate dictPRepr
---

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index c77343b..a7c463b 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -248,6 +248,13 @@ buildFromPRepr _ vect_tc prepr_tc _
                   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
@@ -416,7 +423,8 @@ buildPADict shape vect_tc prepr_tc arr_tc dfun
 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
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index b00206d..d1c1dab 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -6,7 +6,7 @@ module VectUtils (
   mkPRepr, mkToPRepr, mkFromPRepr,
   mkPADictType, mkPArrayType, mkPReprType,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
-  prDictOfType,
+  prDictOfType, prCoerce,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
@@ -23,6 +23,7 @@ import VectMonad
 import DsUtils
 import CoreSyn
 import CoreUtils
+import Coercion
 import Type
 import TypeRep
 import TyCon
@@ -255,7 +256,6 @@ 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
@@ -286,6 +286,17 @@ mkDFunArg 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