Merge remote branch 'origin/master'

[ghc-hetmet.git] / compiler / vectorise / Vectorise / Type / Env.hs

diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 18de832..4910464 100644 (file)
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -1,11 +1,9 @@
-{-# OPTIONS_GHC -XNoMonoLocalBinds -fno-warn-missing-signatures #-}
--- Roman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
 
 module Vectorise.Type.Env ( 
        vectTypeEnv,
-)
-where
+) where
+  
 import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Monad
@@ -29,7 +27,6 @@ import FamInstEnv
 import OccName
 import Id
 import MkId
-import Var
 import NameEnv
 
 import Unique
@@ -41,49 +38,58 @@ 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
       -- ones we can pass through unchanged. We also pass through algebraic 
       -- types that use non Haskell98 features, as we don't handle those.
+      let tycons               = typeEnvTyCons env
+          groups               = tyConGroups tycons
+
       let (conv_tcs, keep_tcs) = classifyTyCons cs groups
+          orig_tcs             = keep_tcs ++ conv_tcs
           keep_dcs             = concatMap tyConDataCons keep_tcs
 
+      -- Just use the unvectorised versions of these constructors in vectorised code.
       zipWithM_ defTyCon   keep_tcs keep_tcs
       zipWithM_ defDataCon keep_dcs keep_dcs
 
-      new_tcs <- vectTyConDecls conv_tcs
-
-      let orig_tcs = keep_tcs ++ conv_tcs
+      -- Vectorise all the declarations.
+      new_tcs      <- vectTyConDecls conv_tcs
 
       -- We don't need to make new representation types for dictionary
       -- constructors. The constructors are always fully applied, and we don't 
       -- need to lift them to arrays as a dictionary of a particular type
       -- always has the same value.
-      let vect_tcs = filter (not . isClassTyCon) 
-                   $ keep_tcs ++ new_tcs
-
+      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.
       (_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) ->
         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
@@ -96,28 +102,25 @@ vectTypeEnv env
           binds     <- takeHoisted
           return (dfuns, binds, repr_tcs ++ pdata_tcs)
 
+      -- The new type constructors are the vectorised versions of the originals, 
+      -- plus the new type constructors that we use for the representations.
       let all_new_tcs = new_tcs ++ inst_tcs
 
-      let new_env = extendTypeEnvList env
-                       (map ATyCon all_new_tcs
-                        ++ [ADataCon dc | tc <- all_new_tcs
-                                        , dc <- tyConDataCons tc])
+      let new_env     =  extendTypeEnvList env
+                      $  map ATyCon all_new_tcs
+                      ++ [ADataCon dc | tc <- all_new_tcs
+                                      , dc <- tyConDataCons tc]
 
       return (new_env, map mkLocalFamInst inst_tcs, binds)
-  where
-    tycons = typeEnvTyCons env
-    groups = tyConGroups tycons
 
+   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
@@ -179,7 +182,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
 
           raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineRule body (Just arity)
+                              mkInlineUnfolding (Just arity) body
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where