compiler/vectorise/VectBuiltIn.hs

   1 module VectBuiltIn (
   2   Builtins(..),
   3   initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
   4 ) where
   5
   6 #include "HsVersions.h"
   7
   8 import DsMonad
   9 import IfaceEnv        ( lookupOrig )
  10
  11 import Module          ( Module )
  12 import DataCon         ( DataCon )
  13 import TyCon           ( TyCon, tyConName, tyConDataCons )
  14 import Var             ( Var )
  15 import Id              ( mkSysLocal )
  16 import Name            ( Name )
  17 import OccName         ( mkVarOccFS )
  18
  19 import TypeRep         ( funTyCon )
  20 import TysPrim         ( intPrimTy )
  21 import TysWiredIn      ( unitTyCon, tupleTyCon, intTyConName )
  22 import PrelNames
  23 import BasicTypes      ( Boxity(..) )
  24
  25 import FastString
  26
  27 import Control.Monad   ( liftM, zipWithM )
  28
  29 data Builtins = Builtins {
  30                   parrayTyCon      :: TyCon
  31                 , paTyCon          :: TyCon
  32                 , paDataCon        :: DataCon
  33                 , preprTyCon       :: TyCon
  34                 , prTyCon          :: TyCon
  35                 , prDataCon        :: DataCon
  36                 , embedTyCon       :: TyCon
  37                 , embedDataCon     :: DataCon
  38                 , crossTyCon       :: TyCon
  39                 , crossDataCon     :: DataCon
  40                 , plusTyCon        :: TyCon
  41                 , leftDataCon      :: DataCon
  42                 , rightDataCon     :: DataCon
  43                 , closureTyCon     :: TyCon
  44                 , mkClosureVar     :: Var
  45                 , applyClosureVar  :: Var
  46                 , mkClosurePVar    :: Var
  47                 , applyClosurePVar :: Var
  48                 , lengthPAVar      :: Var
  49                 , replicatePAVar   :: Var
  50                 , emptyPAVar       :: Var
  51                 -- , packPAVar        :: Var
  52                 -- , combinePAVar     :: Var
  53                 , intEqPAVar       :: Var
  54                 , liftingContext   :: Var
  55                 }
  56
  57 initBuiltins :: DsM Builtins
  58 initBuiltins
  59   = do
  60       parrayTyCon  <- dsLookupTyCon parrayTyConName
  61       paTyCon      <- dsLookupTyCon paTyConName
  62       let [paDataCon] = tyConDataCons paTyCon
  63       preprTyCon   <- dsLookupTyCon preprTyConName
  64       prTyCon      <- dsLookupTyCon prTyConName
  65       let [prDataCon] = tyConDataCons prTyCon
  66       embedTyCon   <- dsLookupTyCon embedTyConName
  67       let [embedDataCon] = tyConDataCons embedTyCon
  68       crossTyCon   <- dsLookupTyCon ndpCrossTyConName
  69       let [crossDataCon] = tyConDataCons crossTyCon
  70       plusTyCon    <- dsLookupTyCon ndpPlusTyConName
  71       let [leftDataCon, rightDataCon] = tyConDataCons plusTyCon
  72       closureTyCon <- dsLookupTyCon closureTyConName
  73
  74       mkClosureVar     <- dsLookupGlobalId mkClosureName
  75       applyClosureVar  <- dsLookupGlobalId applyClosureName
  76       mkClosurePVar    <- dsLookupGlobalId mkClosurePName
  77       applyClosurePVar <- dsLookupGlobalId applyClosurePName
  78       lengthPAVar      <- dsLookupGlobalId lengthPAName
  79       replicatePAVar   <- dsLookupGlobalId replicatePAName
  80       emptyPAVar       <- dsLookupGlobalId emptyPAName
  81       -- packPAVar        <- dsLookupGlobalId packPAName
  82       -- combinePAVar     <- dsLookupGlobalId combinePAName
  83       intEqPAVar       <- dsLookupGlobalId intEqPAName
  84
  85       liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
  86                               newUnique
  87
  88       return $ Builtins {
  89                  parrayTyCon      = parrayTyCon
  90                , paTyCon          = paTyCon
  91                , paDataCon        = paDataCon
  92                , preprTyCon       = preprTyCon
  93                , prTyCon          = prTyCon
  94                , prDataCon        = prDataCon
  95                , embedTyCon       = embedTyCon
  96                , embedDataCon     = embedDataCon
  97                , crossTyCon       = crossTyCon
  98                , crossDataCon     = crossDataCon
  99                , plusTyCon        = plusTyCon
 100                , leftDataCon      = leftDataCon
 101                , rightDataCon     = rightDataCon
 102                , closureTyCon     = closureTyCon
 103                , mkClosureVar     = mkClosureVar
 104                , applyClosureVar  = applyClosureVar
 105                , mkClosurePVar    = mkClosurePVar
 106                , applyClosurePVar = applyClosurePVar
 107                , lengthPAVar      = lengthPAVar
 108                , replicatePAVar   = replicatePAVar
 109                , emptyPAVar       = emptyPAVar
 110                -- , packPAVar        = packPAVar
 111                -- , combinePAVar     = combinePAVar
 112                , intEqPAVar       = intEqPAVar
 113                , liftingContext   = liftingContext
 114                }
 115
 116 initBuiltinTyCons :: DsM [(Name, TyCon)]
 117 initBuiltinTyCons
 118   = do
 119       vects <- sequence vs
 120       return (zip origs vects)
 121   where
 122     (origs, vs) = unzip builtinTyCons
 123
 124 builtinTyCons :: [(Name, DsM TyCon)]
 125 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
 126
 127 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
 128 initBuiltinDicts ps
 129   = do
 130       dicts <- zipWithM lookupExternalVar mods fss
 131       return $ zip tcs dicts
 132   where
 133     (tcs, mods, fss) = unzip3 ps
 134
 135 initBuiltinPAs = initBuiltinDicts builtinPAs
 136
 137 builtinPAs :: [(Name, Module, FastString)]
 138 builtinPAs = [
 139                mk closureTyConName  nDP_CLOSURE   FSLIT("dPA_Clo")
 140              , mk unitTyConName     nDP_PARRAY    FSLIT("dPA_Unit")
 141
 142              , mk intTyConName      nDP_INSTANCES FSLIT("dPA_Int")
 143              ]
 144              ++ tups
 145   where
 146     mk name mod fs = (name, mod, fs)
 147
 148     tups = map mk_tup [2..3]
 149     mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
 150                   nDP_INSTANCES
 151                   (mkFastString $ "dPA_" ++ show n)
 152
 153 initBuiltinPRs = initBuiltinDicts builtinPRs
 154
 155 builtinPRs :: [(Name, Module, FastString)]
 156 builtinPRs = [
 157                mk (tyConName unitTyCon) nDP_PARRAY    FSLIT("dPR_Unit")
 158              , mk ndpCrossTyConName     nDP_PARRAY    FSLIT("dPR_Cross")
 159              , mk ndpPlusTyConName      nDP_PARRAY    FSLIT("dPR_Plus")
 160              , mk embedTyConName        nDP_PARRAY    FSLIT("dPR_Embed")
 161              , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
 162
 163                -- temporary
 164              , mk intTyConName          nDP_INSTANCES FSLIT("dPR_Int")
 165              ]
 166   where
 167     mk name mod fs = (name, mod, fs)
 168
 169 lookupExternalVar :: Module -> FastString -> DsM Var
 170 lookupExternalVar mod fs
 171   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 172
 173 unitTyConName = tyConName unitTyCon
 174