Use n-ary sums and products for NDP's generic representation

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

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 7a96e25..0afef5b 100644 (file)
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,6 +1,6 @@
 module VectBuiltIn (
-  Builtins(..),
-  initBuiltins, initBuiltinTyCons, initBuiltinPAs
+  Builtins(..), sumTyCon, prodTyCon,
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
 ) where
 
 #include "HsVersions.h"
@@ -14,7 +14,7 @@ import TyCon           ( TyCon, tyConName, tyConDataCons )
 import Var             ( Var )
 import Id              ( mkSysLocal )
 import Name            ( Name )
-import OccName         ( mkVarOccFS )
+import OccName         ( mkVarOccFS, mkOccNameFS, tcName )
 
 import TypeRep         ( funTyCon )
 import TysPrim         ( intPrimTy )
@@ -23,9 +23,17 @@ import PrelNames
 import BasicTypes      ( Boxity(..) )
 
 import FastString
+import Outputable
 
+import Data.Array
 import Control.Monad   ( liftM, zipWithM )
 
+mAX_NDP_PROD :: Int
+mAX_NDP_PROD = 3
+
+mAX_NDP_SUM :: Int
+mAX_NDP_SUM = 3
+
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon
                 , paTyCon          :: TyCon
@@ -35,11 +43,7 @@ data Builtins = Builtins {
                 , prDataCon        :: DataCon
                 , embedTyCon       :: TyCon
                 , embedDataCon     :: DataCon
-                , crossTyCon       :: TyCon
-                , crossDataCon     :: DataCon
-                , plusTyCon        :: TyCon
-                , leftDataCon      :: DataCon
-                , rightDataCon     :: DataCon
+                , sumTyCons        :: Array Int TyCon
                 , closureTyCon     :: TyCon
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var
@@ -54,6 +58,17 @@ data Builtins = Builtins {
                 , liftingContext   :: Var
                 }
 
+sumTyCon :: Int -> Builtins -> TyCon
+sumTyCon n bi
+  | n >= 2 && n <= mAX_NDP_SUM = sumTyCons bi ! n
+  | otherwise = pprPanic "sumTyCon" (ppr n)
+
+prodTyCon :: Int -> Builtins -> TyCon
+prodTyCon n bi
+  | n >= 2 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
+  | otherwise = pprPanic "prodTyCon" (ppr n)
+
+
 initBuiltins :: DsM Builtins
 initBuiltins
   = do
@@ -65,12 +80,13 @@ initBuiltins
       let [prDataCon] = tyConDataCons prTyCon
       embedTyCon   <- dsLookupTyCon embedTyConName
       let [embedDataCon] = tyConDataCons embedTyCon
-      crossTyCon   <- dsLookupTyCon ndpCrossTyConName
-      let [crossDataCon] = tyConDataCons crossTyCon
-      plusTyCon    <- dsLookupTyCon ndpPlusTyConName
-      let [leftDataCon, rightDataCon] = tyConDataCons plusTyCon
       closureTyCon <- dsLookupTyCon closureTyConName
 
+      sum_tcs <- mapM (lookupExternalTyCon nDP_REPR)
+                      [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]]
+
+      let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs
+
       mkClosureVar     <- dsLookupGlobalId mkClosureName
       applyClosureVar  <- dsLookupGlobalId applyClosureName
       mkClosurePVar    <- dsLookupGlobalId mkClosurePName
@@ -94,11 +110,7 @@ initBuiltins
                , prDataCon        = prDataCon
                , embedTyCon       = embedTyCon
                , embedDataCon     = embedDataCon
-               , crossTyCon       = crossTyCon
-               , crossDataCon     = crossDataCon
-               , plusTyCon        = plusTyCon
-               , leftDataCon      = leftDataCon
-               , rightDataCon     = rightDataCon
+               , sumTyCons        = sumTyCons
                , closureTyCon     = closureTyCon
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar
@@ -124,32 +136,63 @@ initBuiltinTyCons
 builtinTyCons :: [(Name, DsM TyCon)]
 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
 
-initBuiltinPAs :: DsM [(Name, Var)]
-initBuiltinPAs
+initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
+initBuiltinDicts ps
   = do
-      pas <- zipWithM lookupExternalVar mods fss
-      return $ zip tcs pas
+      dicts <- zipWithM lookupExternalVar mods fss
+      return $ zip tcs dicts
   where
-    (tcs, mods, fss) = unzip3 builtinPAs
+    (tcs, mods, fss) = unzip3 ps
+
+initBuiltinPAs = initBuiltinDicts builtinPAs
 
 builtinPAs :: [(Name, Module, FastString)]
 builtinPAs = [
-               mk closureTyConName      nDP_CLOSURE FSLIT("dPA_Clo")
-             , mk (tyConName unitTyCon) nDP_PARRAY  FSLIT("dPA_Unit")
+               mk closureTyConName  nDP_CLOSURE   FSLIT("dPA_Clo")
+             , mk unitTyConName     nDP_INSTANCES FSLIT("dPA_Unit")
 
-             , temporary intTyConName FSLIT("dPA_Int")
+             , mk intTyConName      nDP_INSTANCES 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)
+    mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
+                  nDP_INSTANCES
+                  (mkFastString $ "dPA_" ++ show n)
+
+initBuiltinPRs = initBuiltinDicts . builtinPRs
+
+builtinPRs :: Builtins -> [(Name, Module, FastString)]
+builtinPRs bi =
+  [
+    mk (tyConName unitTyCon) nDP_REPR      FSLIT("dPR_Unit")
+  , mk embedTyConName        nDP_REPR      FSLIT("dPR_Embed")
+  , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
+
+    -- temporary
+  , mk intTyConName          nDP_INSTANCES FSLIT("dPR_Int")
+  ]
+
+  ++ map mk_sum  [2..mAX_NDP_SUM]
+  ++ map mk_prod [2..mAX_NDP_PROD]
+  where
+    mk name mod fs = (name, mod, fs)
+
+    mk_sum n = (tyConName $ sumTyCon n bi, nDP_REPR,
+                mkFastString ("dPR_Sum" ++ show n))
+
+    mk_prod n = (tyConName $ prodTyCon n bi, nDP_REPR,
+                 mkFastString ("dPR_" ++ show n))
 
 lookupExternalVar :: Module -> FastString -> DsM Var
 lookupExternalVar mod fs
   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 
+lookupExternalTyCon :: Module -> FastString -> DsM TyCon
+lookupExternalTyCon mod fs
+  = dsLookupTyCon =<< lookupOrig mod (mkOccNameFS tcName fs)
+
+unitTyConName = tyConName unitTyCon
+