From 774c6bf14c504bc8bccc8dd134e4010f3ee43ccb Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Thu, 23 Aug 2007 02:36:58 +0000
Subject: [PATCH] Add generation of PR dictionaries

---
 compiler/vectorise/VectUtils.hs |   32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index cb1aa3e..b00206d 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -6,6 +6,7 @@ module VectUtils (
   mkPRepr, mkToPRepr, mkFromPRepr,
   mkPADictType, mkPArrayType, mkPReprType,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
+  prDictOfType,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
@@ -254,6 +255,37 @@ 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)
+
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
   where
-- 
1.7.10.4