X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectBuiltIn.hs;h=8f23687b10d103b24de94d5da31c80e5dfa136cc;hb=054019538c6ac004d2dc5abd639cf953c8c485ef;hp=2d20b83c9521423a24b543428cc83617119d13cf;hpb=83937bef9abc2c60c6018d12cbc3fa080ab47d74;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 2d20b83..8f23687 100644
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,6 +1,8 @@
 module VectBuiltIn (
   Builtins(..), sumTyCon, prodTyCon,
-  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs,
+
+  primMethod, primPArray
 ) where
 
 #include "HsVersions.h"
@@ -13,11 +15,13 @@ import DataCon         ( DataCon )
 import TyCon           ( TyCon, tyConName, tyConDataCons )
 import Var             ( Var )
 import Id              ( mkSysLocal )
-import Name            ( Name )
-import OccName         ( mkVarOccFS, mkOccNameFS, tcName )
+import Name            ( Name, getOccString )
+import NameEnv
+import OccName
 
 import TypeRep         ( funTyCon )
-import TysPrim         ( intPrimTy )
+import Type            ( Type )
+import TysPrim
 import TysWiredIn      ( unitTyCon, tupleTyCon, intTyConName )
 import PrelNames
 import BasicTypes      ( Boxity(..) )
@@ -41,7 +45,8 @@ data Builtins = Builtins {
                 , preprTyCon       :: TyCon
                 , prTyCon          :: TyCon
                 , prDataCon        :: DataCon
-                , uarrTyCon        :: TyCon
+                , parrayIntPrimTyCon :: TyCon
+                , wrapTyCon        :: TyCon
                 , sumTyCons        :: Array Int TyCon
                 , closureTyCon     :: TyCon
                 , mkPRVar          :: Var
@@ -49,12 +54,13 @@ data Builtins = Builtins {
                 , applyClosureVar  :: Var
                 , mkClosurePVar    :: Var
                 , applyClosurePVar :: Var
+                , replicatePAIntPrimVar :: Var
+                , upToPAIntPrimVar :: Var
                 , lengthPAVar      :: Var
                 , replicatePAVar   :: Var
                 , emptyPAVar       :: Var
                 -- , packPAVar        :: Var
                 -- , combinePAVar     :: Var
-                , intEqPAVar       :: Var
                 , liftingContext   :: Var
                 }
 
@@ -65,10 +71,10 @@ sumTyCon n bi
 
 prodTyCon :: Int -> Builtins -> TyCon
 prodTyCon n bi
-  | n >= 2 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
+  | n == 1                      = wrapTyCon bi
+  | n >= 0 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
   | otherwise = pprPanic "prodTyCon" (ppr n)
 
-
 initBuiltins :: DsM Builtins
 initBuiltins
   = do
@@ -77,10 +83,11 @@ initBuiltins
       let [paDataCon] = tyConDataCons paTyCon
       preprTyCon   <- dsLookupTyCon preprTyConName
       prTyCon      <- dsLookupTyCon prTyConName
-      uarrTyCon    <- dsLookupTyCon uarrTyConName
       let [prDataCon] = tyConDataCons prTyCon
+      parrayIntPrimTyCon <- dsLookupTyCon parrayIntPrimTyConName
       closureTyCon <- dsLookupTyCon closureTyConName
 
+      wrapTyCon    <- lookupExternalTyCon nDP_REPR FSLIT("Wrap")
       sum_tcs <- mapM (lookupExternalTyCon nDP_REPR)
                       [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]]
 
@@ -91,12 +98,13 @@ initBuiltins
       applyClosureVar  <- dsLookupGlobalId applyClosureName
       mkClosurePVar    <- dsLookupGlobalId mkClosurePName
       applyClosurePVar <- dsLookupGlobalId applyClosurePName
+      replicatePAIntPrimVar <- dsLookupGlobalId replicatePAIntPrimName
+      upToPAIntPrimVar <- dsLookupGlobalId upToPAIntPrimName
       lengthPAVar      <- dsLookupGlobalId lengthPAName
       replicatePAVar   <- dsLookupGlobalId replicatePAName
       emptyPAVar       <- dsLookupGlobalId emptyPAName
       -- packPAVar        <- dsLookupGlobalId packPAName
       -- combinePAVar     <- dsLookupGlobalId combinePAName
-      intEqPAVar       <- dsLookupGlobalId intEqPAName
 
       liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
                               newUnique
@@ -108,7 +116,8 @@ initBuiltins
                , preprTyCon       = preprTyCon
                , prTyCon          = prTyCon
                , prDataCon        = prDataCon
-               , uarrTyCon        = uarrTyCon
+               , parrayIntPrimTyCon = parrayIntPrimTyCon
+               , wrapTyCon        = wrapTyCon
                , sumTyCons        = sumTyCons
                , closureTyCon     = closureTyCon
                , mkPRVar          = mkPRVar
@@ -116,12 +125,13 @@ initBuiltins
                , applyClosureVar  = applyClosureVar
                , mkClosurePVar    = mkClosurePVar
                , applyClosurePVar = applyClosurePVar
+               , replicatePAIntPrimVar = replicatePAIntPrimVar
+               , upToPAIntPrimVar = upToPAIntPrimVar
                , lengthPAVar      = lengthPAVar
                , replicatePAVar   = replicatePAVar
                , emptyPAVar       = emptyPAVar
                -- , packPAVar        = packPAVar
                -- , combinePAVar     = combinePAVar
-               , intEqPAVar       = intEqPAVar
                , liftingContext   = liftingContext
                }
 
@@ -168,6 +178,7 @@ builtinPRs :: Builtins -> [(Name, Module, FastString)]
 builtinPRs bi =
   [
     mk (tyConName unitTyCon) nDP_REPR      FSLIT("dPR_Unit")
+  , mk (tyConName $ wrapTyCon bi) nDP_REPR FSLIT("dPR_Wrap")
   , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
 
     -- temporary
@@ -195,3 +206,23 @@ lookupExternalTyCon mod fs
 
 unitTyConName = tyConName unitTyCon
 
+
+primMethod :: TyCon -> String -> DsM (Maybe Var)
+primMethod tycon method
+  | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
+  = liftM Just
+  $ dsLookupGlobalId =<< lookupOrig nDP_PRIM (mkVarOcc $ method ++ suffix)
+
+  | otherwise = return Nothing
+
+primPArray :: TyCon -> DsM (Maybe TyCon)
+primPArray tycon
+  | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
+  = liftM Just
+  $ dsLookupTyCon =<< lookupOrig nDP_PRIM (mkOccName tcName $ "PArray" ++ suffix)
+
+  | otherwise = return Nothing
+
+prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
+  where
+    mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)