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, classTyCon )
  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                 , fromVoidVar      :: Var
 117                 , punitVar         :: 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 >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
 158   | otherwise = pprPanic "prodTyCon" (ppr n)
 159
 160 prodDataCon :: Int -> Builtins -> DataCon
 161 prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of
 162                      [con] -> con
 163                      _     -> pprPanic "prodDataCon" (ppr n)
 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      <- externalClassTyCon dph_PArray (fsLit "PA")
 181       let [paDataCon] = tyConDataCons paTyCon
 182       preprTyCon   <- externalTyCon dph_PArray (fsLit "PRepr")
 183       prTyCon      <- externalClassTyCon 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       fromVoidVar      <- externalVar dph_Repr (fsLit "fromVoid")
 209       punitVar         <- externalVar dph_Repr (fsLit "punit")
 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                , fromVoidVar      = fromVoidVar
 258                , punitVar         = punitVar
 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_Scalar         = dph_Scalar
 279              })
 280       = dph_Modules pkg
 281
 282     numbered :: String -> Int -> Int -> [FastString]
 283     numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
 284
 285     mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
 286     mk_elements (i,j)
 287       = do
 288           v <- externalVar dph_Selector
 289              $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
 290           return ((i,j), Var v)
 291
 292
 293 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
 294 initBuiltinVars (Builtins { dphModules = mods })
 295   = do
 296       uvars <- zipWithM externalVar umods ufs
 297       vvars <- zipWithM externalVar vmods vfs
 298       cvars <- zipWithM externalVar cmods cfs
 299       return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
 300                ++ zip (map dataConWorkId cons) cvars
 301                ++ zip uvars vvars
 302   where
 303     (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
 304
 305     (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
 306
 307 defaultDataConWorkers :: [DataCon]
 308 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
 309
 310 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
 311 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
 312   = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
 313   where
 314     mk_tup n mod name = (tupleCon Boxed n, mod, name)
 315
 316 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
 317 preludeVars (Modules { dph_Combinators    = dph_Combinators
 318                      , dph_PArray         = dph_PArray
 319                      , dph_Prelude_Int    = dph_Prelude_Int
 320                      , dph_Prelude_Word8  = dph_Prelude_Word8
 321                      , dph_Prelude_Double = dph_Prelude_Double
 322                      , dph_Prelude_Bool   = dph_Prelude_Bool
 323                      , dph_Prelude_PArr   = dph_Prelude_PArr
 324                      })
 325   = [
 326       mk gHC_PARR (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
 327     , mk gHC_PARR (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
 328     , mk gHC_PARR (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
 329     , mk gHC_PARR (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
 330     , mk gHC_PARR (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
 331     , mk gHC_PARR (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
 332     , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
 333     , mk gHC_PARR (fsLit "!:")         dph_Combinators (fsLit "indexPA")
 334     , mk gHC_PARR (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
 335     , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
 336     , mk gHC_PARR (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
 337     , mk gHC_PARR (fsLit "+:+")        dph_Combinators (fsLit "appPA")
 338     , mk gHC_PARR (fsLit "emptyP")     dph_PArray (fsLit "emptyPA")
 339
 340     , mk' dph_Prelude_Int "div"  "divV"
 341     , mk' dph_Prelude_Int "mod"  "modV"
 342     , mk' dph_Prelude_Int "sqrt" "sqrtV"
 343     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
 344     -- , mk' dph_Prelude_Int "upToP" "upToPA"
 345     ]
 346     ++ vars_Ord dph_Prelude_Int
 347     ++ vars_Num dph_Prelude_Int
 348
 349     ++ vars_Ord dph_Prelude_Word8
 350     ++ vars_Num dph_Prelude_Word8
 351     ++
 352     [ mk' dph_Prelude_Word8 "div" "divV"
 353     , mk' dph_Prelude_Word8 "mod" "modV"
 354     , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
 355     , mk' dph_Prelude_Word8 "toInt" "toIntV"
 356     ]
 357
 358     ++ vars_Ord dph_Prelude_Double
 359     ++ vars_Num dph_Prelude_Double
 360     ++ vars_Fractional dph_Prelude_Double
 361     ++ vars_Floating dph_Prelude_Double
 362     ++ vars_RealFrac dph_Prelude_Double
 363     ++
 364     [ mk dph_Prelude_Bool  (fsLit "andP")  dph_Prelude_Bool (fsLit "andPA")
 365     , mk dph_Prelude_Bool  (fsLit "orP")  dph_Prelude_Bool (fsLit "orPA")
 366
 367     -- FIXME: temporary
 368     , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
 369     , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
 370     , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
 371     , mk dph_Prelude_PArr (fsLit "combineP")    dph_Combinators (fsLit "combine2PA")
 372     ]
 373   where
 374     mk  = (,,,)
 375     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
 376
 377     vars_Ord mod = [mk' mod "=="  "eqV"
 378                    ,mk' mod "/=" "neqV"
 379                    ,mk' mod "<="  "leV"
 380                    ,mk' mod "<"   "ltV"
 381                    ,mk' mod ">="  "geV"
 382                    ,mk' mod ">"   "gtV"
 383                    ,mk' mod "min" "minV"
 384                    ,mk' mod "max" "maxV"
 385                    ,mk' mod "minimumP" "minimumPA"
 386                    ,mk' mod "maximumP" "maximumPA"
 387                    ,mk' mod "minIndexP" "minIndexPA"
 388                    ,mk' mod "maxIndexP" "maxIndexPA"
 389                    ]
 390
 391     vars_Num mod = [mk' mod "+"        "plusV"
 392                    ,mk' mod "-"        "minusV"
 393                    ,mk' mod "*"        "multV"
 394                    ,mk' mod "negate"   "negateV"
 395                    ,mk' mod "abs"      "absV"
 396                    ,mk' mod "sumP"     "sumPA"
 397                    ,mk' mod "productP" "productPA"
 398                    ]
 399
 400     vars_Fractional mod = [mk' mod "/"     "divideV"
 401                           ,mk' mod "recip" "recipV"
 402                           ]
 403
 404     vars_Floating mod = [mk' mod "pi" "pi"
 405                         ,mk' mod "exp" "expV"
 406                         ,mk' mod "sqrt" "sqrtV"
 407                         ,mk' mod "log" "logV"
 408                         ,mk' mod "sin" "sinV"
 409                         ,mk' mod "tan" "tanV"
 410                         ,mk' mod "cos" "cosV"
 411                         ,mk' mod "asin" "asinV"
 412                         ,mk' mod "atan" "atanV"
 413                         ,mk' mod "acos" "acosV"
 414                         ,mk' mod "sinh" "sinhV"
 415                         ,mk' mod "tanh" "tanhV"
 416                         ,mk' mod "cosh" "coshV"
 417                         ,mk' mod "asinh" "asinhV"
 418                         ,mk' mod "atanh" "atanhV"
 419                         ,mk' mod "acosh" "acoshV"
 420                         ,mk' mod "**"    "powV"
 421                         ,mk' mod "logBase" "logBaseV"
 422                         ]
 423
 424     vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
 425                         ,mk' mod "truncate" "truncateV"
 426                         ,mk' mod "round" "roundV"
 427                         ,mk' mod "ceiling" "ceilingV"
 428                         ,mk' mod "floor" "floorV"
 429                         ]
 430
 431 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
 432 initBuiltinTyCons bi
 433   = do
 434       -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
 435       dft_tcs <- defaultTyCons
 436       return $ (tyConName funTyCon, closureTyCon bi)
 437              : (parrTyConName,      parrayTyCon bi)
 438
 439              -- FIXME: temporary
 440              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
 441
 442              : [(tyConName tc, tc) | tc <- dft_tcs]
 443
 444 defaultTyCons :: DsM [TyCon]
 445 defaultTyCons
 446   = do
 447       word8 <- dsLookupTyCon word8TyConName
 448       return [intTyCon, boolTyCon, doubleTyCon, word8]
 449
 450 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
 451 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
 452
 453 defaultDataCons :: [DataCon]
 454 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
 455
 456 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
 457 initBuiltinDicts ps
 458   = do
 459       dicts <- zipWithM externalVar mods fss
 460       return $ zip tcs dicts
 461   where
 462     (tcs, mods, fss) = unzip3 ps
 463
 464 initBuiltinPAs :: Builtins -> DsM [(Name, Var)]
 465 initBuiltinPAs = initBuiltinDicts . builtinPAs
 466
 467 builtinPAs :: Builtins -> [(Name, Module, FastString)]
 468 builtinPAs bi@(Builtins { dphModules = mods })
 469   = [
 470       mk (tyConName $ closureTyCon bi)  (dph_Closure   mods) (fsLit "$fPA:->")
 471     , mk (tyConName $ voidTyCon bi)     (dph_Repr      mods) (fsLit "$fPAVoid")
 472     , mk (tyConName $ parrayTyCon bi)   (dph_Instances mods) (fsLit "$fPAPArray")
 473     , mk unitTyConName                  (dph_Instances mods) (fsLit "$fPA()")
 474
 475     , mk intTyConName                   (dph_Instances mods) (fsLit "$fPAInt")
 476     , mk word8TyConName                 (dph_Instances mods) (fsLit "$fPAWord8")
 477     , mk doubleTyConName                (dph_Instances mods) (fsLit "$fPADouble")
 478     , mk boolTyConName                  (dph_Instances mods) (fsLit "$fPABool")
 479     ]
 480     ++ tups
 481   where
 482     mk name mod fs = (name, mod, fs)
 483
 484     tups = map mk_tup [2..mAX_DPH_PROD]
 485     mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
 486                   (dph_Instances mods)
 487                   (mkFastString $ "$fPA(" ++ replicate (n-1) ',' ++ ")")
 488
 489 initBuiltinPRs :: Builtins -> DsM [(Name, Var)]
 490 initBuiltinPRs = initBuiltinDicts . builtinPRs
 491
 492 builtinPRs :: Builtins -> [(Name, Module, FastString)]
 493 builtinPRs bi@(Builtins { dphModules = mods }) =
 494   [
 495     mk (tyConName   unitTyCon)           (dph_Repr mods)    (fsLit "$fPR()")
 496   , mk (tyConName $ voidTyCon        bi) (dph_Repr mods)    (fsLit "$fPRVoid")
 497   , mk (tyConName $ wrapTyCon        bi) (dph_Repr mods)    (fsLit "$fPRWrap")
 498   , mk (tyConName $ closureTyCon     bi) (dph_Closure mods) (fsLit "$fPR:->")
 499
 500     -- temporary
 501   , mk intTyConName          (dph_Instances mods) (fsLit "$fPRInt")
 502   , mk word8TyConName        (dph_Instances mods) (fsLit "$fPRWord8")
 503   , mk doubleTyConName       (dph_Instances mods) (fsLit "$fPRDouble")
 504   ]
 505
 506   ++ map mk_sum  [2..mAX_DPH_SUM]
 507   ++ map mk_prod [2..mAX_DPH_PROD]
 508   where
 509     mk name mod fs = (name, mod, fs)
 510
 511     mk_sum n = (tyConName $ sumTyCon n bi, dph_Repr mods,
 512                 mkFastString ("$fPRSum" ++ show n))
 513
 514     mk_prod n = (tyConName $ prodTyCon n bi, dph_Repr mods,
 515                  mkFastString ("$fPR(" ++ replicate (n-1) ',' ++ ")"))
 516
 517 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
 518 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
 519
 520 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
 521 builtinBoxedTyCons _ =
 522   [(tyConName intPrimTyCon, intTyCon)]
 523
 524
 525 initBuiltinScalars :: Builtins -> DsM [Var]
 526 initBuiltinScalars bi
 527   = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
 528
 529
 530 preludeScalars :: Modules -> [(Module, FastString)]
 531 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
 532                         , dph_Prelude_Word8  = dph_Prelude_Word8
 533                         , dph_Prelude_Double = dph_Prelude_Double
 534                         })
 535   = [
 536       mk dph_Prelude_Int "div"
 537     , mk dph_Prelude_Int "mod"
 538     , mk dph_Prelude_Int "sqrt"
 539     ]
 540     ++ scalars_Ord dph_Prelude_Int
 541     ++ scalars_Num dph_Prelude_Int
 542
 543     ++ scalars_Ord dph_Prelude_Word8
 544     ++ scalars_Num dph_Prelude_Word8
 545     ++
 546     [ mk dph_Prelude_Word8 "div"
 547     , mk dph_Prelude_Word8 "mod"
 548     , mk dph_Prelude_Word8 "fromInt"
 549     , mk dph_Prelude_Word8 "toInt"
 550     ]
 551
 552     ++ scalars_Ord dph_Prelude_Double
 553     ++ scalars_Num dph_Prelude_Double
 554     ++ scalars_Fractional dph_Prelude_Double
 555     ++ scalars_Floating dph_Prelude_Double
 556     ++ scalars_RealFrac dph_Prelude_Double
 557   where
 558     mk mod s = (mod, fsLit s)
 559
 560     scalars_Ord mod = [mk mod "=="
 561                       ,mk mod "/="
 562                       ,mk mod "<="
 563                       ,mk mod "<"
 564                       ,mk mod ">="
 565                       ,mk mod ">"
 566                       ,mk mod "min"
 567                       ,mk mod "max"
 568                       ]
 569
 570     scalars_Num mod = [mk mod "+"
 571                       ,mk mod "-"
 572                       ,mk mod "*"
 573                       ,mk mod "negate"
 574                       ,mk mod "abs"
 575                       ]
 576
 577     scalars_Fractional mod = [mk mod "/"
 578                              ,mk mod "recip"
 579                              ]
 580
 581     scalars_Floating mod = [mk mod "pi"
 582                            ,mk mod "exp"
 583                            ,mk mod "sqrt"
 584                            ,mk mod "log"
 585                            ,mk mod "sin"
 586                            ,mk mod "tan"
 587                            ,mk mod "cos"
 588                            ,mk mod "asin"
 589                            ,mk mod "atan"
 590                            ,mk mod "acos"
 591                            ,mk mod "sinh"
 592                            ,mk mod "tanh"
 593                            ,mk mod "cosh"
 594                            ,mk mod "asinh"
 595                            ,mk mod "atanh"
 596                            ,mk mod "acosh"
 597                            ,mk mod "**"
 598                            ,mk mod "logBase"
 599                            ]
 600
 601     scalars_RealFrac mod = [mk mod "fromInt"
 602                            ,mk mod "truncate"
 603                            ,mk mod "round"
 604                            ,mk mod "ceiling"
 605                            ,mk mod "floor"
 606                            ]
 607
 608
 609 externalVar :: Module -> FastString -> DsM Var
 610 externalVar mod fs
 611   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 612
 613 externalFun :: Module -> FastString -> DsM CoreExpr
 614 externalFun mod fs
 615   = do
 616       var <- externalVar mod fs
 617       return $ Var var
 618
 619 externalTyCon :: Module -> FastString -> DsM TyCon
 620 externalTyCon mod fs
 621   = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
 622
 623 externalClassTyCon :: Module -> FastString -> DsM TyCon
 624 externalClassTyCon mod fs
 625   = liftM classTyCon
 626   $ dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
 627
 628 externalType :: Module -> FastString -> DsM Type
 629 externalType mod fs
 630   = do
 631       tycon <- externalTyCon mod fs
 632       return $ mkTyConApp tycon []
 633
 634 externalClass :: Module -> FastString -> DsM Class
 635 externalClass mod fs
 636   = dsLookupClass =<< lookupOrig mod (mkTcOccFS fs)
 637
 638 unitTyConName :: Name
 639 unitTyConName = tyConName unitTyCon
 640
 641
 642 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
 643 primMethod  tycon method (Builtins { dphModules = mods })
 644   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 645   = liftM Just
 646   $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
 647                                     (mkVarOcc $ method ++ suffix)
 648
 649   | otherwise = return Nothing
 650
 651 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
 652 primPArray tycon (Builtins { dphModules = mods })
 653   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 654   = liftM Just
 655   $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
 656                                  (mkTcOcc $ "PArray" ++ suffix)
 657
 658   | otherwise = return Nothing
 659
 660 prim_ty_cons :: NameEnv String
 661 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
 662   where
 663     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
 664