Move all vectorisation built-ins to VectBuiltIn

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 1ff3418..7a96e25 100644 (file)
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,20 +1,30 @@
 module VectBuiltIn (
 module VectBuiltIn (

-  Builtins(..), initBuiltins
+  Builtins(..),
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs

 ) where
 
 #include "HsVersions.h"
 
 import DsMonad
 ) where
 
 #include "HsVersions.h"
 
 import DsMonad

+import IfaceEnv        ( lookupOrig )

 
 

+import Module          ( Module )

 import DataCon         ( DataCon )
 import DataCon         ( DataCon )

-import TyCon           ( TyCon, tyConDataCons )
+import TyCon           ( TyCon, tyConName, tyConDataCons )

 import Var             ( Var )
 import Id              ( mkSysLocal )
 import Var             ( Var )
 import Id              ( mkSysLocal )

+import Name            ( Name )
+import OccName         ( mkVarOccFS )

 
 

+import TypeRep         ( funTyCon )

 import TysPrim         ( intPrimTy )
 import TysPrim         ( intPrimTy )

+import TysWiredIn      ( unitTyCon, tupleTyCon, intTyConName )

 import PrelNames
 import PrelNames

+import BasicTypes      ( Boxity(..) )

 
 

-import Control.Monad   ( liftM )
+import FastString
+
+import Control.Monad   ( liftM, zipWithM )

 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon
 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon

@@ -103,4 +113,43 @@ initBuiltins
                , liftingContext   = liftingContext
                }
 
                , liftingContext   = liftingContext
                }
 

+initBuiltinTyCons :: DsM [(Name, TyCon)]
+initBuiltinTyCons
+  = do
+      vects <- sequence vs
+      return (zip origs vects)
+  where
+    (origs, vs) = unzip builtinTyCons
+
+builtinTyCons :: [(Name, DsM TyCon)]
+builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
+
+initBuiltinPAs :: DsM [(Name, Var)]
+initBuiltinPAs
+  = do
+      pas <- zipWithM lookupExternalVar mods fss
+      return $ zip tcs pas
+  where
+    (tcs, mods, fss) = unzip3 builtinPAs
+
+builtinPAs :: [(Name, Module, FastString)]
+builtinPAs = [
+               mk closureTyConName      nDP_CLOSURE FSLIT("dPA_Clo")
+             , mk (tyConName unitTyCon) nDP_PARRAY  FSLIT("dPA_Unit")
+
+             , temporary intTyConName FSLIT("dPA_Int")
+             ]
+             ++ tups
+  where
+    mk name mod fs = (name, mod, fs)
+
+    temporary name fs = (name, nDP_INSTANCES, fs)
+
+    tups = map mk_tup [2..3]
+    mk_tup n = temporary (tyConName $ tupleTyCon Boxed n)
+                         (mkFastString $ "dPA_" ++ show n)
+
+lookupExternalVar :: Module -> FastString -> DsM Var
+lookupExternalVar mod fs
+  = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)

 
 

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 75df2b7..6cb1679 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -22,7 +22,7 @@ module VectMonad (
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,

-  lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
+  lookupTyConPA, defTyConPA, defTyConPAs,

   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst

@@ -119,17 +119,13 @@ data LocalEnv = LocalEnv {
                  -- Local binding name
                , local_bind_name :: FastString
                }
                  -- Local binding name
                , local_bind_name :: FastString
                }

-              

 
 

-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins
-              -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs bi
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs

   = GlobalEnv {
       global_vars          = mapVarEnv snd $ vectInfoVar info
     , global_exported_vars = emptyVarEnv
   = GlobalEnv {
       global_vars          = mapVarEnv snd $ vectInfoVar info
     , global_exported_vars = emptyVarEnv

-    , global_tycons        = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
-                                           (tyConName funTyCon) (closureTyCon bi)
-                              
+    , global_tycons        = mapNameEnv snd $ vectInfoTyCon info

     , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
     , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
     , global_inst_env      = instEnvs
     , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
     , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
     , global_inst_env      = instEnvs

@@ -143,6 +139,14 @@ setFamInstEnv l_fam_inst genv
   where
     (g_fam_inst, _) = global_fam_inst_env genv
 
   where
     (g_fam_inst, _) = global_fam_inst_env genv
 

+extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+extendTyConsEnv ps genv
+  = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+
+extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+extendPAFunsEnv ps genv
+  = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+

 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []

@@ -258,11 +262,6 @@ inBind id p
   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
        p
 
   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
        p
 

-lookupExternalVar :: Module -> FastString -> VM Var
-lookupExternalVar mod fs
-  = liftDs
-  $ dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
-

 cloneName :: (OccName -> OccName) -> Name -> VM Name
 cloneName mk_occ name = liftM make (liftDs newUnique)
   where
 cloneName :: (OccName -> OccName) -> Name -> VM Name
 cloneName mk_occ name = liftM make (liftDs newUnique)
   where

@@ -354,16 +353,6 @@ defTyConPAs ps = updGEnv $ \env ->
   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 
   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 

-defTyConBuiltinPAs :: [(Name, Module, FastString)] -> VM ()
-defTyConBuiltinPAs ps
-  = do
-      pas <- zipWithM lookupExternalVar mods fss
-      updGEnv $ \env ->
-        env { global_pa_funs = extendNameEnvList (global_pa_funs env)
-                                                 (zip tcs pas) }
-  where
-    (tcs, mods, fss) = unzip3 ps
-

 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
 
 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
 

@@ -454,11 +443,14 @@ initV hsc_env guts info p
     go instEnvs famInstEnvs = 
       do
         builtins <- initBuiltins
     go instEnvs famInstEnvs = 
       do
         builtins <- initBuiltins

-        r <- runVM p builtins (initGlobalEnv info
-                                             instEnvs
-                                             famInstEnvs
-                                             builtins)
-                   emptyLocalEnv
+        builtin_tycons <- initBuiltinTyCons
+        builtin_pas    <- initBuiltinPAs
+
+        let genv = extendTyConsEnv builtin_tycons
+                 . extendPAFunsEnv builtin_pas
+                 $ initGlobalEnv info instEnvs famInstEnvs
+
+        r <- runVM p builtins genv emptyLocalEnv

         case r of
           Yes genv _ x -> return $ Just (new_info genv, x)
           No           -> return Nothing
         case r of
           Yes genv _ x -> return $ Just (new_info genv, x)
           No           -> return Nothing

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 31defa5..85f4e46 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -45,19 +45,6 @@ import Outputable
 import FastString
 import Control.Monad        ( liftM, liftM2, zipWithM, mapAndUnzipM )
 
 import FastString
 import Control.Monad        ( liftM, liftM2, zipWithM, mapAndUnzipM )
 

-builtin_PAs :: [(Name, Module, FastString)]
-builtin_PAs = [
-                (closureTyConName, nDP_CLOSURE, FSLIT("dPA_Clo"))
-              , mk intTyConName     FSLIT("dPA_Int")
-              ]
-              ++ tups
-  where
-    mk name fs = (name, nDP_INSTANCES, fs)
-
-    tups = mk_tup 0 : map mk_tup [2..3]
-    mk_tup n   = (getName $ tupleTyCon Boxed n, nDP_INSTANCES,
-                  mkFastString $ "dPA_" ++ show n)
-

 vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
           -> IO (SimplCount, ModGuts)
 vectorise hsc_env _ _ guts
 vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
           -> IO (SimplCount, ModGuts)
 vectorise hsc_env _ _ guts

@@ -74,7 +61,6 @@ vectorise hsc_env _ _ guts
 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do

-      defTyConBuiltinPAs builtin_PAs

       (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
       
       let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
       (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
       
       let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts