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