compiler/vectorise/VectBuiltIn.hs

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