From e12e8c14196fc87d15b382ef4c0201418f83b815 Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Tue, 7 Aug 2007 02:31:54 +0000
Subject: [PATCH] Support for using built-in PA dictionaries for some types

---
 compiler/vectorise/VectMonad.hs |   12 +++++++++++-
 compiler/vectorise/Vectorise.hs |   11 ++++++++++-
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 36e0d97..6da501f 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -21,7 +21,7 @@ module VectMonad (
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,
-  lookupTyConPA, defTyConPA,
+  lookupTyConPA, defTyConPA, defTyConRdrPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   lookupInst, lookupFamInst
@@ -413,6 +413,16 @@ defTyConPA :: TyCon -> Var -> VM ()
 defTyConPA tc pa = updGEnv $ \env ->
   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 
+defTyConRdrPAs :: [(Name, RdrName)] -> VM ()
+defTyConRdrPAs ps
+  = do
+      pas <- mapM lookupRdrVar rdr_names
+      updGEnv $ \env ->
+        env { global_pa_funs = extendNameEnvList (global_pa_funs env)
+                                                 (zip tcs pas) }
+  where
+    (tcs, rdr_names) = unzip ps
+
 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
 
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index bbfa562..bb5aa0d 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -25,11 +25,13 @@ import InstEnv              ( extendInstEnvList )
 import Var
 import VarEnv
 import VarSet
-import Name                 ( mkSysTvName, getName )
+import Name                 ( Name, mkSysTvName, getName )
 import NameEnv
 import Id
 import MkId                 ( unwrapFamInstScrut )
 import OccName
+import RdrName              ( RdrName, mkRdrQual )
+import Module               ( mkModuleNameFS )
 
 import DsMonad hiding (mapAndUnzipM)
 import DsUtils              ( mkCoreTup, mkCoreTupTy )
@@ -44,6 +46,12 @@ import Outputable
 import FastString
 import Control.Monad        ( liftM, liftM2, zipWithM, mapAndUnzipM )
 
+mkNDPVar :: FastString -> RdrName
+mkNDPVar fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs)
+
+builtin_PAs :: [(Name, RdrName)]
+builtin_PAs = [(intTyConName, mkNDPVar FSLIT("dPA_Int"))]
+
 vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
           -> IO (SimplCount, ModGuts)
 vectorise hsc_env _ _ guts
@@ -60,6 +68,7 @@ vectorise hsc_env _ _ guts
 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
+      defTyConRdrPAs builtin_PAs
       (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts)
       
       let insts         = map painstInstance pa_insts
-- 
1.7.10.4