compiler/vectorise/VectBuiltIn.hs

   1 module VectBuiltIn (
   2   Builtins(..), sumTyCon, prodTyCon, prodDataCon,
   3   selTy, selReplicate, selPick, selElements,
   4   combinePDVar, scalarZip, closureCtrFun,
   5   initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
   6   initBuiltinPAs, initBuiltinPRs,
   7   initBuiltinBoxedTyCons, initBuiltinScalars,
   8
   9   primMethod, primPArray
  10 ) where
  11
  12 import DsMonad
  13 import IfaceEnv        ( lookupOrig )
  14
  15 import Module
  16 import DataCon         ( DataCon, dataConName, dataConWorkId )
  17 import TyCon           ( TyCon, tyConName, tyConDataCons )
  18 import Class           ( Class )
  19 import CoreSyn         ( CoreExpr, Expr(..) )
  20 import Var             ( Var )
  21 import Id              ( mkSysLocal )
  22 import Name            ( Name, getOccString )
  23 import NameEnv
  24 import OccName
  25
  26 import TypeRep         ( funTyCon )
  27 import Type            ( Type, mkTyConApp )
  28 import TysPrim
  29 import TysWiredIn      ( unitTyCon, unitDataCon,
  30                          tupleTyCon, tupleCon,
  31                          intTyCon, intTyConName,
  32                          doubleTyCon, doubleTyConName,
  33                          boolTyCon, boolTyConName, trueDataCon, falseDataCon,
  34                          parrTyConName )
  35 import PrelNames       ( word8TyConName, gHC_PARR )
  36 import BasicTypes      ( Boxity(..) )
  37
  38 import FastString
  39 import Outputable
  40
  41 import Data.Array
  42 import Control.Monad   ( liftM, zipWithM )
  43 import Data.List       ( unzip4 )
  44
  45 mAX_DPH_PROD :: Int
  46 mAX_DPH_PROD = 5
  47
  48 mAX_DPH_SUM :: Int
  49 mAX_DPH_SUM = 2
  50
  51 mAX_DPH_COMBINE :: Int
  52 mAX_DPH_COMBINE = 2
  53
  54 mAX_DPH_SCALAR_ARGS :: Int
  55 mAX_DPH_SCALAR_ARGS = 3
  56
  57 data Modules = Modules {
  58                    dph_PArray :: Module
  59                  , dph_Repr :: Module
  60                  , dph_Closure :: Module
  61                  , dph_Unboxed :: Module
  62                  , dph_Instances :: Module
  63                  , dph_Combinators :: Module
  64                  , dph_Scalar :: Module
  65                  , dph_Selector :: Module
  66                  , dph_Prelude_PArr :: Module
  67                  , dph_Prelude_Int :: Module
  68                  , dph_Prelude_Word8 :: Module
  69                  , dph_Prelude_Double :: Module
  70                  , dph_Prelude_Bool :: Module
  71                  , dph_Prelude_Tuple :: Module
  72                }
  73
  74 dph_Modules :: PackageId -> Modules
  75 dph_Modules pkg = Modules {
  76     dph_PArray         = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
  77   , dph_Repr           = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
  78   , dph_Closure        = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
  79   , dph_Unboxed        = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
  80   , dph_Instances      = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
  81   , dph_Combinators    = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
  82   , dph_Scalar         = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
  83   , dph_Selector       = mk (fsLit "Data.Array.Parallel.Lifted.Selector")
  84
  85   , dph_Prelude_PArr   = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
  86   , dph_Prelude_Int    = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
  87   , dph_Prelude_Word8  = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
  88   , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
  89   , dph_Prelude_Bool   = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
  90   , dph_Prelude_Tuple  = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
  91   }
  92   where
  93     mk = mkModule pkg . mkModuleNameFS
  94
  95
  96 data Builtins = Builtins {
  97                   dphModules       :: Modules
  98                 , parrayTyCon      :: TyCon
  99                 , parrayDataCon    :: DataCon
 100                 , pdataTyCon       :: TyCon
 101                 , paTyCon          :: TyCon
 102                 , paDataCon        :: DataCon
 103                 , preprTyCon       :: TyCon
 104                 , prTyCon          :: TyCon
 105                 , prDataCon        :: DataCon
 106                 , voidTyCon        :: TyCon
 107                 , wrapTyCon        :: TyCon
 108                 , selTys           :: Array Int Type
 109                 , selReplicates    :: Array Int CoreExpr
 110                 , selPicks         :: Array Int CoreExpr
 111                 , selEls           :: Array (Int, Int) CoreExpr
 112                 , sumTyCons        :: Array Int TyCon
 113                 , closureTyCon     :: TyCon
 114                 , voidVar          :: Var
 115                 , pvoidVar         :: Var
 116                 , punitVar         :: Var
 117                 , mkPRVar          :: Var
 118                 , closureVar       :: Var
 119                 , applyVar         :: Var
 120                 , liftedClosureVar :: Var
 121                 , liftedApplyVar   :: Var
 122                 , replicatePDVar   :: Var
 123                 , emptyPDVar       :: Var
 124                 , packPDVar        :: Var
 125                 , combinePDVars    :: Array Int Var
 126                 , scalarClass      :: Class
 127                 , scalarZips       :: Array Int Var
 128                 , closureCtrFuns   :: Array Int Var
 129                 , liftingContext   :: Var
 130                 }
 131
 132 indexBuiltin :: (Ix i, Outputable i) => String -> (Builtins -> Array i a)
 133                                         -> i -> Builtins -> a
 134 indexBuiltin fn f i bi
 135   | inRange (bounds xs) i = xs ! i
 136   | otherwise = pprPanic fn (ppr i)
 137   where
 138     xs = f bi
 139
 140 selTy :: Int -> Builtins -> Type
 141 selTy = indexBuiltin "selTy" selTys
 142
 143 selReplicate :: Int -> Builtins -> CoreExpr
 144 selReplicate = indexBuiltin "selReplicate" selReplicates
 145
 146 selPick :: Int -> Builtins -> CoreExpr
 147 selPick = indexBuiltin "selPick" selPicks
 148
 149 selElements :: Int -> Int -> Builtins -> CoreExpr
 150 selElements i j = indexBuiltin "selElements" selEls (i,j)
 151
 152 sumTyCon :: Int -> Builtins -> TyCon
 153 sumTyCon = indexBuiltin "sumTyCon" sumTyCons
 154
 155 prodTyCon :: Int -> Builtins -> TyCon
 156 prodTyCon n bi
 157   | n == 1                      = wrapTyCon bi
 158   | n >= 0 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
 159   | otherwise = pprPanic "prodTyCon" (ppr n)
 160
 161 prodDataCon :: Int -> Builtins -> DataCon
 162 prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of
 163                      [con] -> con
 164
 165 combinePDVar :: Int -> Builtins -> Var
 166 combinePDVar = indexBuiltin "combinePDVar" combinePDVars
 167
 168 scalarZip :: Int -> Builtins -> Var
 169 scalarZip = indexBuiltin "scalarZip" scalarZips
 170
 171 closureCtrFun :: Int -> Builtins -> Var
 172 closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
 173
 174 initBuiltins :: PackageId -> DsM Builtins
 175 initBuiltins pkg
 176   = do
 177       parrayTyCon  <- externalTyCon dph_PArray (fsLit "PArray")
 178       let [parrayDataCon] = tyConDataCons parrayTyCon
 179       pdataTyCon   <- externalTyCon dph_PArray (fsLit "PData")
 180       paTyCon      <- externalTyCon dph_PArray (fsLit "PA")
 181       let [paDataCon] = tyConDataCons paTyCon
 182       preprTyCon   <- externalTyCon dph_PArray (fsLit "PRepr")
 183       prTyCon      <- externalTyCon dph_PArray (fsLit "PR")
 184       let [prDataCon] = tyConDataCons prTyCon
 185       closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
 186
 187       voidTyCon    <- externalTyCon dph_Repr (fsLit "Void")
 188       wrapTyCon    <- externalTyCon dph_Repr (fsLit "Wrap")
 189       sel_tys      <- mapM (externalType dph_Selector)
 190                            (numbered "Sel" 2 mAX_DPH_SUM)
 191       sel_replicates <- mapM (externalFun dph_Selector)
 192                              (numbered "replicate" 2 mAX_DPH_SUM)
 193       sel_picks    <- mapM (externalFun dph_Selector)
 194                            (numbered "pick" 2 mAX_DPH_SUM)
 195       sel_els      <- mapM mk_elements
 196                            [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
 197       sum_tcs      <- mapM (externalTyCon dph_Repr)
 198                            (numbered "Sum" 2 mAX_DPH_SUM)
 199
 200       let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
 201           selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
 202           selPicks      = listArray (2, mAX_DPH_SUM) sel_picks
 203           selEls        = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
 204           sumTyCons     = listArray (2, mAX_DPH_SUM) sum_tcs
 205
 206       voidVar          <- externalVar dph_Repr (fsLit "void")
 207       pvoidVar         <- externalVar dph_Repr (fsLit "pvoid")
 208       punitVar         <- externalVar dph_Repr (fsLit "punit")
 209       mkPRVar          <- externalVar dph_PArray (fsLit "mkPR")
 210       closureVar       <- externalVar dph_Closure (fsLit "closure")
 211       applyVar         <- externalVar dph_Closure (fsLit "$:")
 212       liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
 213       liftedApplyVar   <- externalVar dph_Closure (fsLit "liftedApply")
 214       replicatePDVar   <- externalVar dph_PArray (fsLit "replicatePD")
 215       emptyPDVar       <- externalVar dph_PArray (fsLit "emptyPD")
 216       packPDVar        <- externalVar dph_PArray (fsLit "packPD")
 217
 218       combines <- mapM (externalVar dph_PArray)
 219                        [mkFastString ("combine" ++ show i ++ "PD")
 220                           | i <- [2..mAX_DPH_COMBINE]]
 221       let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
 222
 223       scalarClass <- externalClass dph_Scalar (fsLit "Scalar")
 224       scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
 225       scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
 226       scalar_zips <- mapM (externalVar dph_Scalar)
 227                           (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
 228       let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
 229                                  (scalar_map : scalar_zip2 : scalar_zips)
 230       closures <- mapM (externalVar dph_Closure)
 231                        (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
 232       let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
 233
 234       liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
 235                               newUnique
 236
 237       return $ Builtins {
 238                  dphModules       = modules
 239                , parrayTyCon      = parrayTyCon
 240                , parrayDataCon    = parrayDataCon
 241                , pdataTyCon       = pdataTyCon
 242                , paTyCon          = paTyCon
 243                , paDataCon        = paDataCon
 244                , preprTyCon       = preprTyCon
 245                , prTyCon          = prTyCon
 246                , prDataCon        = prDataCon
 247                , voidTyCon        = voidTyCon
 248                , wrapTyCon        = wrapTyCon
 249                , selTys           = selTys
 250                , selReplicates    = selReplicates
 251                , selPicks         = selPicks
 252                , selEls           = selEls
 253                , sumTyCons        = sumTyCons
 254                , closureTyCon     = closureTyCon
 255                , voidVar          = voidVar
 256                , pvoidVar         = pvoidVar
 257                , punitVar         = punitVar
 258                , mkPRVar          = mkPRVar
 259                , closureVar       = closureVar
 260                , applyVar         = applyVar
 261                , liftedClosureVar = liftedClosureVar
 262                , liftedApplyVar   = liftedApplyVar
 263                , replicatePDVar   = replicatePDVar
 264                , emptyPDVar       = emptyPDVar
 265                , packPDVar        = packPDVar
 266                , combinePDVars    = combinePDVars
 267                , scalarClass      = scalarClass
 268                , scalarZips       = scalarZips
 269                , closureCtrFuns   = closureCtrFuns
 270                , liftingContext   = liftingContext
 271                }
 272   where
 273     modules@(Modules {
 274                dph_PArray         = dph_PArray
 275              , dph_Repr           = dph_Repr
 276              , dph_Closure        = dph_Closure
 277              , dph_Selector       = dph_Selector
 278              , dph_Unboxed        = dph_Unboxed
 279              , dph_Scalar         = dph_Scalar
 280              })
 281       = dph_Modules pkg
 282
 283     numbered :: String -> Int -> Int -> [FastString]
 284     numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
 285
 286     mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
 287     mk_elements (i,j)
 288       = do
 289           v <- externalVar dph_Selector
 290              $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
 291           return ((i,j), Var v)
 292
 293
 294 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
 295 initBuiltinVars (Builtins { dphModules = mods })
 296   = do
 297       uvars <- zipWithM externalVar umods ufs
 298       vvars <- zipWithM externalVar vmods vfs
 299       cvars <- zipWithM externalVar cmods cfs
 300       return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
 301                ++ zip (map dataConWorkId cons) cvars
 302                ++ zip uvars vvars
 303   where
 304     (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
 305
 306     (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
 307
 308 defaultDataConWorkers :: [DataCon]
 309 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
 310
 311 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
 312 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
 313   = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
 314   where
 315     mk_tup n mod name = (tupleCon Boxed n, mod, name)
 316
 317 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
 318 preludeVars (Modules { dph_Combinators    = dph_Combinators
 319                      , dph_PArray         = dph_PArray
 320                      , dph_Prelude_Int    = dph_Prelude_Int
 321                      , dph_Prelude_Word8  = dph_Prelude_Word8
 322                      , dph_Prelude_Double = dph_Prelude_Double
 323                      , dph_Prelude_Bool   = dph_Prelude_Bool
 324                      , dph_Prelude_PArr   = dph_Prelude_PArr
 325                      })
 326   = [
 327       mk gHC_PARR (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
 328     , mk gHC_PARR (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
 329     , mk gHC_PARR (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
 330     , mk gHC_PARR (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
 331     , mk gHC_PARR (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
 332     , mk gHC_PARR (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
 333     , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
 334     , mk gHC_PARR (fsLit "!:")         dph_Combinators (fsLit "indexPA")
 335     , mk gHC_PARR (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
 336     , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
 337     , mk gHC_PARR (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
 338     , mk gHC_PARR (fsLit "+:+")        dph_Combinators (fsLit "appPA")
 339     , mk gHC_PARR (fsLit "emptyP")     dph_PArray (fsLit "emptyPA")
 340
 341     , mk' dph_Prelude_Int "div"  "divV"
 342     , mk' dph_Prelude_Int "mod"  "modV"
 343     , mk' dph_Prelude_Int "sqrt" "sqrtV"
 344     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
 345     -- , mk' dph_Prelude_Int "upToP" "upToPA"
 346     ]
 347     ++ vars_Ord dph_Prelude_Int
 348     ++ vars_Num dph_Prelude_Int
 349
 350     ++ vars_Ord dph_Prelude_Word8
 351     ++ vars_Num dph_Prelude_Word8
 352     ++
 353     [ mk' dph_Prelude_Word8 "div" "divV"
 354     , mk' dph_Prelude_Word8 "mod" "modV"
 355     , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
 356     , mk' dph_Prelude_Word8 "toInt" "toIntV"
 357     ]
 358
 359     ++ vars_Ord dph_Prelude_Double
 360     ++ vars_Num dph_Prelude_Double
 361     ++ vars_Fractional dph_Prelude_Double
 362     ++ vars_Floating dph_Prelude_Double
 363     ++ vars_RealFrac dph_Prelude_Double
 364     ++
 365     [ mk dph_Prelude_Bool  (fsLit "andP")  dph_Prelude_Bool (fsLit "andPA")
 366     , mk dph_Prelude_Bool  (fsLit "orP")  dph_Prelude_Bool (fsLit "orPA")
 367
 368     -- FIXME: temporary
 369     , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
 370     , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
 371     , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
 372     , mk dph_Prelude_PArr (fsLit "combineP")    dph_Combinators (fsLit "combine2PA")
 373     ]
 374   where
 375     mk  = (,,,)
 376     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
 377
 378     vars_Ord mod = [mk' mod "=="  "eqV"
 379                    ,mk' mod "/=" "neqV"
 380                    ,mk' mod "<="  "leV"
 381                    ,mk' mod "<"   "ltV"
 382                    ,mk' mod ">="  "geV"
 383                    ,mk' mod ">"   "gtV"
 384                    ,mk' mod "min" "minV"
 385                    ,mk' mod "max" "maxV"
 386                    ,mk' mod "minimumP" "minimumPA"
 387                    ,mk' mod "maximumP" "maximumPA"
 388                    ,mk' mod "minIndexP" "minIndexPA"
 389                    ,mk' mod "maxIndexP" "maxIndexPA"
 390                    ]
 391
 392     vars_Num mod = [mk' mod "+"        "plusV"
 393                    ,mk' mod "-"        "minusV"
 394                    ,mk' mod "*"        "multV"
 395                    ,mk' mod "negate"   "negateV"
 396                    ,mk' mod "abs"      "absV"
 397                    ,mk' mod "sumP"     "sumPA"
 398                    ,mk' mod "productP" "productPA"
 399                    ]
 400
 401     vars_Fractional mod = [mk' mod "/"     "divideV"
 402                           ,mk' mod "recip" "recipV"
 403                           ]
 404
 405     vars_Floating mod = [mk' mod "pi" "pi"
 406                         ,mk' mod "exp" "expV"
 407                         ,mk' mod "sqrt" "sqrtV"
 408                         ,mk' mod "log" "logV"
 409                         ,mk' mod "sin" "sinV"
 410                         ,mk' mod "tan" "tanV"
 411                         ,mk' mod "cos" "cosV"
 412                         ,mk' mod "asin" "asinV"
 413                         ,mk' mod "atan" "atanV"
 414                         ,mk' mod "acos" "acosV"
 415                         ,mk' mod "sinh" "sinhV"
 416                         ,mk' mod "tanh" "tanhV"
 417                         ,mk' mod "cosh" "coshV"
 418                         ,mk' mod "asinh" "asinhV"
 419                         ,mk' mod "atanh" "atanhV"
 420                         ,mk' mod "acosh" "acoshV"
 421                         ,mk' mod "**"    "powV"
 422                         ,mk' mod "logBase" "logBaseV"
 423                         ]
 424
 425     vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
 426                         ,mk' mod "truncate" "truncateV"
 427                         ,mk' mod "round" "roundV"
 428                         ,mk' mod "ceiling" "ceilingV"
 429                         ,mk' mod "floor" "floorV"
 430                         ]
 431
 432 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
 433 initBuiltinTyCons bi
 434   = do
 435       -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
 436       dft_tcs <- defaultTyCons
 437       return $ (tyConName funTyCon, closureTyCon bi)
 438              : (parrTyConName,      parrayTyCon bi)
 439
 440              -- FIXME: temporary
 441              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
 442
 443              : [(tyConName tc, tc) | tc <- dft_tcs]
 444
 445 defaultTyCons :: DsM [TyCon]
 446 defaultTyCons
 447   = do
 448       word8 <- dsLookupTyCon word8TyConName
 449       return [intTyCon, boolTyCon, doubleTyCon, word8]
 450
 451 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
 452 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
 453
 454 defaultDataCons :: [DataCon]
 455 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
 456
 457 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
 458 initBuiltinDicts ps
 459   = do
 460       dicts <- zipWithM externalVar mods fss
 461       return $ zip tcs dicts
 462   where
 463     (tcs, mods, fss) = unzip3 ps
 464
 465 initBuiltinPAs :: Builtins -> DsM [(Name, Var)]
 466 initBuiltinPAs = initBuiltinDicts . builtinPAs
 467
 468 builtinPAs :: Builtins -> [(Name, Module, FastString)]
 469 builtinPAs bi@(Builtins { dphModules = mods })
 470   = [
 471       mk (tyConName $ closureTyCon bi)  (dph_Closure   mods) (fsLit "dPA_Clo")
 472     , mk (tyConName $ voidTyCon bi)     (dph_Repr      mods) (fsLit "dPA_Void")
 473     , mk (tyConName $ parrayTyCon bi)   (dph_Instances mods) (fsLit "dPA_PArray")
 474     , mk unitTyConName                  (dph_Instances mods) (fsLit "dPA_Unit")
 475
 476     , mk intTyConName                   (dph_Instances mods) (fsLit "dPA_Int")
 477     , mk word8TyConName                 (dph_Instances mods) (fsLit "dPA_Word8")
 478     , mk doubleTyConName                (dph_Instances mods) (fsLit "dPA_Double")
 479     , mk boolTyConName                  (dph_Instances mods) (fsLit "dPA_Bool")
 480     ]
 481     ++ tups
 482   where
 483     mk name mod fs = (name, mod, fs)
 484
 485     tups = map mk_tup [2..mAX_DPH_PROD]
 486     mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
 487                   (dph_Instances mods)
 488                   (mkFastString $ "dPA_" ++ show n)
 489
 490 initBuiltinPRs :: Builtins -> DsM [(Name, Var)]
 491 initBuiltinPRs = initBuiltinDicts . builtinPRs
 492
 493 builtinPRs :: Builtins -> [(Name, Module, FastString)]
 494 builtinPRs bi@(Builtins { dphModules = mods }) =
 495   [
 496     mk (tyConName   unitTyCon)           (dph_Repr mods)    (fsLit "dPR_Unit")
 497   , mk (tyConName $ voidTyCon        bi) (dph_Repr mods)    (fsLit "dPR_Void")
 498   , mk (tyConName $ wrapTyCon        bi) (dph_Repr mods)    (fsLit "dPR_Wrap")
 499   , mk (tyConName $ closureTyCon     bi) (dph_Closure mods) (fsLit "dPR_Clo")
 500
 501     -- temporary
 502   , mk intTyConName          (dph_Instances mods) (fsLit "dPR_Int")
 503   , mk word8TyConName        (dph_Instances mods) (fsLit "dPR_Word8")
 504   , mk doubleTyConName       (dph_Instances mods) (fsLit "dPR_Double")
 505   ]
 506
 507   ++ map mk_sum  [2..mAX_DPH_SUM]
 508   ++ map mk_prod [2..mAX_DPH_PROD]
 509   where
 510     mk name mod fs = (name, mod, fs)
 511
 512     mk_sum n = (tyConName $ sumTyCon n bi, dph_Repr mods,
 513                 mkFastString ("dPR_Sum" ++ show n))
 514
 515     mk_prod n = (tyConName $ prodTyCon n bi, dph_Repr mods,
 516                  mkFastString ("dPR_" ++ show n))
 517
 518 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
 519 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
 520
 521 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
 522 builtinBoxedTyCons _ =
 523   [(tyConName intPrimTyCon, intTyCon)]
 524
 525
 526 initBuiltinScalars :: Builtins -> DsM [Var]
 527 initBuiltinScalars bi
 528   = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
 529
 530
 531 preludeScalars :: Modules -> [(Module, FastString)]
 532 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
 533                         , dph_Prelude_Word8  = dph_Prelude_Word8
 534                         , dph_Prelude_Double = dph_Prelude_Double
 535                         })
 536   = [
 537       mk dph_Prelude_Int "div"
 538     , mk dph_Prelude_Int "mod"
 539     , mk dph_Prelude_Int "sqrt"
 540     ]
 541     ++ scalars_Ord dph_Prelude_Int
 542     ++ scalars_Num dph_Prelude_Int
 543
 544     ++ scalars_Ord dph_Prelude_Word8
 545     ++ scalars_Num dph_Prelude_Word8
 546     ++
 547     [ mk dph_Prelude_Word8 "div"
 548     , mk dph_Prelude_Word8 "mod"
 549     , mk dph_Prelude_Word8 "fromInt"
 550     , mk dph_Prelude_Word8 "toInt"
 551     ]
 552
 553     ++ scalars_Ord dph_Prelude_Double
 554     ++ scalars_Num dph_Prelude_Double
 555     ++ scalars_Fractional dph_Prelude_Double
 556     ++ scalars_Floating dph_Prelude_Double
 557     ++ scalars_RealFrac dph_Prelude_Double
 558   where
 559     mk mod s = (mod, fsLit s)
 560
 561     scalars_Ord mod = [mk mod "=="
 562                       ,mk mod "/="
 563                       ,mk mod "<="
 564                       ,mk mod "<"
 565                       ,mk mod ">="
 566                       ,mk mod ">"
 567                       ,mk mod "min"
 568                       ,mk mod "max"
 569                       ]
 570
 571     scalars_Num mod = [mk mod "+"
 572                       ,mk mod "-"
 573                       ,mk mod "*"
 574                       ,mk mod "negate"
 575                       ,mk mod "abs"
 576                       ]
 577
 578     scalars_Fractional mod = [mk mod "/"
 579                              ,mk mod "recip"
 580                              ]
 581
 582     scalars_Floating mod = [mk mod "pi"
 583                            ,mk mod "exp"
 584                            ,mk mod "sqrt"
 585                            ,mk mod "log"
 586                            ,mk mod "sin"
 587                            ,mk mod "tan"
 588                            ,mk mod "cos"
 589                            ,mk mod "asin"
 590                            ,mk mod "atan"
 591                            ,mk mod "acos"
 592                            ,mk mod "sinh"
 593                            ,mk mod "tanh"
 594                            ,mk mod "cosh"
 595                            ,mk mod "asinh"
 596                            ,mk mod "atanh"
 597                            ,mk mod "acosh"
 598                            ,mk mod "**"
 599                            ,mk mod "logBase"
 600                            ]
 601
 602     scalars_RealFrac mod = [mk mod "fromInt"
 603                            ,mk mod "truncate"
 604                            ,mk mod "round"
 605                            ,mk mod "ceiling"
 606                            ,mk mod "floor"
 607                            ]
 608
 609
 610 externalVar :: Module -> FastString -> DsM Var
 611 externalVar mod fs
 612   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 613
 614 externalFun :: Module -> FastString -> DsM CoreExpr
 615 externalFun mod fs
 616   = do
 617       var <- externalVar mod fs
 618       return $ Var var
 619
 620 externalTyCon :: Module -> FastString -> DsM TyCon
 621 externalTyCon mod fs
 622   = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
 623
 624 externalType :: Module -> FastString -> DsM Type
 625 externalType mod fs
 626   = do
 627       tycon <- externalTyCon mod fs
 628       return $ mkTyConApp tycon []
 629
 630 externalClass :: Module -> FastString -> DsM Class
 631 externalClass mod fs
 632   = dsLookupClass =<< lookupOrig mod (mkTcOccFS fs)
 633
 634 unitTyConName :: Name
 635 unitTyConName = tyConName unitTyCon
 636
 637
 638 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
 639 primMethod  tycon method (Builtins { dphModules = mods })
 640   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 641   = liftM Just
 642   $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
 643                                     (mkVarOcc $ method ++ suffix)
 644
 645   | otherwise = return Nothing
 646
 647 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
 648 primPArray tycon (Builtins { dphModules = mods })
 649   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 650   = liftM Just
 651   $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
 652                                  (mkTcOcc $ "PArray" ++ suffix)
 653
 654   | otherwise = return Nothing
 655
 656 prim_ty_cons :: NameEnv String
 657 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
 658   where
 659     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
 660