X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FType%2FEnv.hs;h=49104647097c983857688a2b38df73aa6b973aaa;hp=99c17464dd81075851cc6e1145c3d4c25e03ae07;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857

diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 99c1746..4910464 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -1,12 +1,9 @@
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Roman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
 
 module Vectorise.Type.Env ( 
 	vectTypeEnv,
-)
-where
+) where
+  
 import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Monad
@@ -30,7 +27,6 @@ import FamInstEnv
 import OccName
 import Id
 import MkId
-import Var
 import NameEnv
 
 import Unique
@@ -42,20 +38,18 @@ import MonadUtils
 import Control.Monad
 import Data.List
 
-debug		= False
-dtrace s x	= if debug then pprTrace "VectType" s x else x
 
 -- | Vectorise a type environment.
 --   The type environment contains all the type things defined in a module.
-vectTypeEnv 
-	:: TypeEnv
-	-> VM ( TypeEnv			-- Vectorised type environment.
-	      , [FamInst]		-- New type family instances.
-	      , [(Var, CoreExpr)])	-- New top level bindings.
-	
+--
+vectTypeEnv :: TypeEnv
+            -> VM ( TypeEnv             -- Vectorised type environment.
+                  , [FamInst]           -- New type family instances.
+                  , [(Var, CoreExpr)])  -- New top level bindings.
 vectTypeEnv env
- = dtrace (ppr env)
- $ do
+  = do
+      traceVt "** vectTypeEnv" $ ppr env
+      
       cs <- readGEnv $ mk_map . global_tycons
 
       -- Split the list of TyCons into the ones we have to vectorise vs the
@@ -82,6 +76,13 @@ vectTypeEnv env
       let vect_tcs  = filter (not . isClassTyCon) 
                     $ keep_tcs ++ new_tcs
 
+      reprs <- mapM tyConRepr vect_tcs
+      repr_tcs  <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs
+      pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs
+      updGEnv $ extendFamEnv
+              $ map mkLocalFamInst
+              $ repr_tcs ++ pdata_tcs
+
       -- Create PRepr and PData instances for the vectorised types.
       -- We get back the binds for the instance functions, 
       -- and some new type constructors for the representation types.
@@ -89,8 +90,6 @@ vectTypeEnv env
         do
           defTyConPAs (zipLazy vect_tcs dfuns')
           reprs     <- mapM tyConRepr vect_tcs
-          repr_tcs  <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs
-          pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs
 
           dfuns     <- sequence 
                     $  zipWith5 buildTyConBindings
@@ -117,14 +116,11 @@ vectTypeEnv env
    where
     mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
 
-
-
 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr -> VM Var
 buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr
  = do vectDataConWorkers orig_tc vect_tc pdata_tc
       buildPADict vect_tc prepr_tc pdata_tc repr
 
-
 vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
 vectDataConWorkers orig_tc vect_tc arr_tc
  = do bs <- sequence