fix typo

[ghc-hetmet.git] / compiler / vectorise / VectBuiltIn.hs

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 1ff3418..e6c65ac 100644 (file)
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,20 +1,30 @@
 module VectBuiltIn (
-  Builtins(..), initBuiltins
+  Builtins(..),
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
 ) where
 
 #include "HsVersions.h"
 
 import DsMonad
+import IfaceEnv        ( lookupOrig )
 
+import Module          ( Module )
 import DataCon         ( DataCon )
-import TyCon           ( TyCon, tyConDataCons )
+import TyCon           ( TyCon, tyConName, tyConDataCons )
 import Var             ( Var )
 import Id              ( mkSysLocal )
+import Name            ( Name )
+import OccName         ( mkVarOccFS )
 
+import TypeRep         ( funTyCon )
 import TysPrim         ( intPrimTy )
+import TysWiredIn      ( unitTyCon, tupleTyCon, intTyConName )
 import PrelNames
+import BasicTypes      ( Boxity(..) )
 
-import Control.Monad   ( liftM )
+import FastString
+
+import Control.Monad   ( liftM, zipWithM )
 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon
@@ -103,4 +113,62 @@ initBuiltins
                , 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)]
+
+initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
+initBuiltinDicts ps
+  = do
+      dicts <- zipWithM lookupExternalVar mods fss
+      return $ zip tcs dicts
+  where
+    (tcs, mods, fss) = unzip3 ps
+
+initBuiltinPAs = initBuiltinDicts builtinPAs
+
+builtinPAs :: [(Name, Module, FastString)]
+builtinPAs = [
+               mk closureTyConName  nDP_CLOSURE   FSLIT("dPA_Clo")
+             , mk unitTyConName     nDP_PARRAY    FSLIT("dPA_Unit")
+
+             , mk intTyConName      nDP_INSTANCES FSLIT("dPA_Int")
+             ]
+             ++ tups
+  where
+    mk name mod fs = (name, mod, fs)
+
+    tups = map mk_tup [2..3]
+    mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
+                  nDP_INSTANCES
+                  (mkFastString $ "dPA_" ++ show n)
+
+initBuiltinPRs = initBuiltinDicts builtinPRs
+
+builtinPRs :: [(Name, Module, FastString)]
+builtinPRs = [
+               mk (tyConName unitTyCon) nDP_PARRAY    FSLIT("dPR_Unit")
+             , mk ndpCrossTyConName     nDP_PARRAY    FSLIT("dPR_Cross")
+             , mk ndpPlusTyConName      nDP_PARRAY    FSLIT("dPR_Plus")
+             , mk embedTyConName        nDP_PARRAY    FSLIT("dPR_Embed")
+             , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
+
+               -- temporary
+             , mk intTyConName          nDP_INSTANCES FSLIT("dPR_Int")
+             ]
+  where
+    mk name mod fs = (name, mod, fs)
+
+lookupExternalVar :: Module -> FastString -> DsM Var
+lookupExternalVar mod fs
+  = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
+
+unitTyConName = tyConName unitTyCon