From 24901afd71ec4776b2949f38c87103eb2cda2985 Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Wed, 18 Jul 2007 04:44:33 +0000
Subject: [PATCH] Add generated PArray instances to instance environments

---
 compiler/vectorise/VectMonad.hs |    8 ++++++++
 compiler/vectorise/VectType.hs  |   14 ++++++++++----
 compiler/vectorise/Vectorise.hs |   18 +++++++++++++++---
 3 files changed, 33 insertions(+), 7 deletions(-)

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index eed5a81..09e2d2f 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -9,6 +9,7 @@ module VectMonad (
   builtin,
 
   GlobalEnv(..),
+  setInstEnvs,
   readGEnv, setGEnv, updGEnv,
 
   LocalEnv(..),
@@ -157,6 +158,13 @@ initGlobalEnv info instEnvs famInstEnvs bi
     , global_bindings      = []
     }
 
+setInstEnvs :: InstEnv -> FamInstEnv -> GlobalEnv -> GlobalEnv
+setInstEnvs l_inst l_fam_inst genv
+  | (g_inst,     _) <- global_inst_env genv
+  , (g_fam_inst, _) <- global_fam_inst_env genv
+  = genv { global_inst_env     = (g_inst, l_inst)
+         , global_fam_inst_env = (g_fam_inst, l_fam_inst) }
+
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index d5a1ba1..5dceb3b 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -12,6 +12,8 @@ import TyCon
 import Type
 import TypeRep
 import Coercion
+import FamInstEnv        ( FamInst, mkLocalFamInst )
+import InstEnv           ( Instance )
 import OccName
 import MkId
 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
@@ -66,7 +68,7 @@ vectType ty = pprPanic "vectType:" (ppr ty)
 
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
-vectTypeEnv :: TypeEnv -> VM TypeEnv
+vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [Instance])
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons
@@ -78,9 +80,13 @@ vectTypeEnv env
       parr_tcs1 <- mapM (\tc -> buildPArrayTyCon (tyConName tc) tc) keep_tcs
       parr_tcs2 <- zipWithM (buildPArrayTyCon . tyConName) conv_tcs vect_tcs
       let new_tcs = vect_tcs ++ parr_tcs1 ++ parr_tcs2
-      return $ extendTypeEnvList env
-                 (map ATyCon new_tcs ++ [ADataCon dc | tc <- new_tcs
-                                                     , dc <- tyConDataCons tc])
+
+      let new_env = extendTypeEnvList env
+                       (map ATyCon new_tcs
+                        ++ [ADataCon dc | tc <- new_tcs
+                                        , dc <- tyConDataCons tc])
+
+      return (new_env, map mkLocalFamInst (parr_tcs1 ++ parr_tcs2), [])
   where
     tycons = typeEnvTyCons env
     groups = tyConGroups tycons
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 286680f..64d46fc 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -19,6 +19,8 @@ import Rules                ( RuleBase )
 import DataCon
 import TyCon
 import Type
+import FamInstEnv           ( extendFamInstEnvList )
+import InstEnv              ( extendInstEnvList )
 import Var
 import VarEnv
 import VarSet
@@ -56,10 +58,20 @@ vectorise hsc_env _ _ guts
 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
-      types' <- vectTypeEnv (mg_types guts)
+      (types', fam_insts, insts) <- vectTypeEnv (mg_types guts)
+
+      let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
+          inst_env'     = extendInstEnvList (mg_inst_env guts) insts
+      updGEnv (setInstEnvs inst_env' fam_inst_env')
+      
       binds' <- mapM vectTopBind (mg_binds guts)
-      return $ guts { mg_types = types'
-                    , mg_binds = binds' }
+      return $ guts { mg_types        = types'
+                    , mg_binds        = binds'
+                    , mg_inst_env     = inst_env'
+                    , mg_fam_inst_env = fam_inst_env'
+                    , mg_insts        = mg_insts guts ++ insts
+                    , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
+                    }
 
 vectTopBind :: CoreBind -> VM CoreBind
 vectTopBind b@(NonRec var expr)
-- 
1.7.10.4