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 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
 334 preludeVars (Modules { dph_Combinators    = dph_Combinators
 335                      , dph_PArray         = dph_PArray
 336                      , dph_Prelude_Int    = dph_Prelude_Int
 337                      , dph_Prelude_Word8  = dph_Prelude_Word8
 338                      , dph_Prelude_Double = dph_Prelude_Double
 339                      , dph_Prelude_Bool   = dph_Prelude_Bool
 340                      , dph_Prelude_PArr   = dph_Prelude_PArr
 341                      })
 342   = [
 343       mk gHC_PARR (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
 344     , mk gHC_PARR (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
 345     , mk gHC_PARR (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
 346     , mk gHC_PARR (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
 347     , mk gHC_PARR (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
 348     , mk gHC_PARR (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
 349     , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
 350     , mk gHC_PARR (fsLit "!:")         dph_Combinators (fsLit "indexPA")
 351     , mk gHC_PARR (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
 352     , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
 353     , mk gHC_PARR (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
 354     , mk gHC_PARR (fsLit "+:+")        dph_Combinators (fsLit "appPA")
 355     , mk gHC_PARR (fsLit "emptyP")     dph_PArray (fsLit "emptyPA")
 356
 357     , mk' dph_Prelude_Int "div"  "divV"
 358     , mk' dph_Prelude_Int "mod"  "modV"
 359     , mk' dph_Prelude_Int "sqrt" "sqrtV"
 360     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
 361     -- , mk' dph_Prelude_Int "upToP" "upToPA"
 362     ]
 363     ++ vars_Ord dph_Prelude_Int
 364     ++ vars_Num dph_Prelude_Int
 365
 366     ++ vars_Ord dph_Prelude_Word8
 367     ++ vars_Num dph_Prelude_Word8
 368     ++
 369     [ mk' dph_Prelude_Word8 "div" "divV"
 370     , mk' dph_Prelude_Word8 "mod" "modV"
 371     , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
 372     , mk' dph_Prelude_Word8 "toInt" "toIntV"
 373     ]
 374
 375     ++ vars_Ord dph_Prelude_Double
 376     ++ vars_Num dph_Prelude_Double
 377     ++ vars_Fractional dph_Prelude_Double
 378     ++ vars_Floating dph_Prelude_Double
 379     ++ vars_RealFrac dph_Prelude_Double
 380     ++
 381     [ mk dph_Prelude_Bool  (fsLit "andP")  dph_Prelude_Bool (fsLit "andPA")
 382     , mk dph_Prelude_Bool  (fsLit "orP")  dph_Prelude_Bool (fsLit "orPA")
 383
 384     -- FIXME: temporary
 385     , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
 386     , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
 387     , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
 388     , mk dph_Prelude_PArr (fsLit "combineP")    dph_Combinators (fsLit "combine2PA")
 389     ]
 390   where
 391     mk  = (,,,)
 392     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
 393
 394     vars_Ord mod = [mk' mod "=="  "eqV"
 395                    ,mk' mod "/=" "neqV"
 396                    ,mk' mod "<="  "leV"
 397                    ,mk' mod "<"   "ltV"
 398                    ,mk' mod ">="  "geV"
 399                    ,mk' mod ">"   "gtV"
 400                    ,mk' mod "min" "minV"
 401                    ,mk' mod "max" "maxV"
 402                    ,mk' mod "minimumP" "minimumPA"
 403                    ,mk' mod "maximumP" "maximumPA"
 404                    ,mk' mod "minIndexP" "minIndexPA"
 405                    ,mk' mod "maxIndexP" "maxIndexPA"
 406                    ]
 407
 408     vars_Num mod = [mk' mod "+"        "plusV"
 409                    ,mk' mod "-"        "minusV"
 410                    ,mk' mod "*"        "multV"
 411                    ,mk' mod "negate"   "negateV"
 412                    ,mk' mod "abs"      "absV"
 413                    ,mk' mod "sumP"     "sumPA"
 414                    ,mk' mod "productP" "productPA"
 415                    ]
 416
 417     vars_Fractional mod = [mk' mod "/"     "divideV"
 418                           ,mk' mod "recip" "recipV"
 419                           ]
 420
 421     vars_Floating mod = [mk' mod "pi" "pi"
 422                         ,mk' mod "exp" "expV"
 423                         ,mk' mod "sqrt" "sqrtV"
 424                         ,mk' mod "log" "logV"
 425                         ,mk' mod "sin" "sinV"
 426                         ,mk' mod "tan" "tanV"
 427                         ,mk' mod "cos" "cosV"
 428                         ,mk' mod "asin" "asinV"
 429                         ,mk' mod "atan" "atanV"
 430                         ,mk' mod "acos" "acosV"
 431                         ,mk' mod "sinh" "sinhV"
 432                         ,mk' mod "tanh" "tanhV"
 433                         ,mk' mod "cosh" "coshV"
 434                         ,mk' mod "asinh" "asinhV"
 435                         ,mk' mod "atanh" "atanhV"
 436                         ,mk' mod "acosh" "acoshV"
 437                         ,mk' mod "**"    "powV"
 438                         ,mk' mod "logBase" "logBaseV"
 439                         ]
 440
 441     vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
 442                         ,mk' mod "truncate" "truncateV"
 443                         ,mk' mod "round" "roundV"
 444                         ,mk' mod "ceiling" "ceilingV"
 445                         ,mk' mod "floor" "floorV"
 446                         ]
 447
 448 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
 449 initBuiltinTyCons bi
 450   = do
 451       -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
 452       dft_tcs <- defaultTyCons
 453       return $ (tyConName funTyCon, closureTyCon bi)
 454              : (parrTyConName,      parrayTyCon bi)
 455
 456              -- FIXME: temporary
 457              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
 458
 459              : [(tyConName tc, tc) | tc <- dft_tcs]
 460
 461 defaultTyCons :: DsM [TyCon]
 462 defaultTyCons
 463   = do
 464       word8 <- dsLookupTyCon word8TyConName
 465       return [intTyCon, boolTyCon, doubleTyCon, word8]
 466
 467 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
 468 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
 469
 470 defaultDataCons :: [DataCon]
 471 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
 472
 473 initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 474 initBuiltinPAs (Builtins { dphModules = mods }) insts
 475   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
 476
 477 initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 478 initBuiltinPRs (Builtins { dphModules = mods }) insts
 479   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
 480
 481 initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
 482 initBuiltinDicts insts cls = map find $ classInstances insts cls
 483   where
 484     find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
 485            | otherwise = pprPanic "Invalid DPH instance" (ppr i)
 486
 487 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
 488 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
 489
 490 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
 491 builtinBoxedTyCons _ =
 492   [(tyConName intPrimTyCon, intTyCon)]
 493
 494
 495 initBuiltinScalars :: Builtins -> DsM [Var]
 496 initBuiltinScalars bi
 497   = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
 498
 499
 500 preludeScalars :: Modules -> [(Module, FastString)]
 501 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
 502                         , dph_Prelude_Word8  = dph_Prelude_Word8
 503                         , dph_Prelude_Double = dph_Prelude_Double
 504                         })
 505   = [
 506       mk dph_Prelude_Int "div"
 507     , mk dph_Prelude_Int "mod"
 508     , mk dph_Prelude_Int "sqrt"
 509     ]
 510     ++ scalars_Ord dph_Prelude_Int
 511     ++ scalars_Num dph_Prelude_Int
 512
 513     ++ scalars_Ord dph_Prelude_Word8
 514     ++ scalars_Num dph_Prelude_Word8
 515     ++
 516     [ mk dph_Prelude_Word8 "div"
 517     , mk dph_Prelude_Word8 "mod"
 518     , mk dph_Prelude_Word8 "fromInt"
 519     , mk dph_Prelude_Word8 "toInt"
 520     ]
 521
 522     ++ scalars_Ord dph_Prelude_Double
 523     ++ scalars_Num dph_Prelude_Double
 524     ++ scalars_Fractional dph_Prelude_Double
 525     ++ scalars_Floating dph_Prelude_Double
 526     ++ scalars_RealFrac dph_Prelude_Double
 527   where
 528     mk mod s = (mod, fsLit s)
 529
 530     scalars_Ord mod = [mk mod "=="
 531                       ,mk mod "/="
 532                       ,mk mod "<="
 533                       ,mk mod "<"
 534                       ,mk mod ">="
 535                       ,mk mod ">"
 536                       ,mk mod "min"
 537                       ,mk mod "max"
 538                       ]
 539
 540     scalars_Num mod = [mk mod "+"
 541                       ,mk mod "-"
 542                       ,mk mod "*"
 543                       ,mk mod "negate"
 544                       ,mk mod "abs"
 545                       ]
 546
 547     scalars_Fractional mod = [mk mod "/"
 548                              ,mk mod "recip"
 549                              ]
 550
 551     scalars_Floating mod = [mk mod "pi"
 552                            ,mk mod "exp"
 553                            ,mk mod "sqrt"
 554                            ,mk mod "log"
 555                            ,mk mod "sin"
 556                            ,mk mod "tan"
 557                            ,mk mod "cos"
 558                            ,mk mod "asin"
 559                            ,mk mod "atan"
 560                            ,mk mod "acos"
 561                            ,mk mod "sinh"
 562                            ,mk mod "tanh"
 563                            ,mk mod "cosh"
 564                            ,mk mod "asinh"
 565                            ,mk mod "atanh"
 566                            ,mk mod "acosh"
 567                            ,mk mod "**"
 568                            ,mk mod "logBase"
 569                            ]
 570
 571     scalars_RealFrac mod = [mk mod "fromInt"
 572                            ,mk mod "truncate"
 573                            ,mk mod "round"
 574                            ,mk mod "ceiling"
 575                            ,mk mod "floor"
 576                            ]
 577
 578
 579 externalVar :: Module -> FastString -> DsM Var
 580 externalVar mod fs
 581   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 582
 583 externalFun :: Module -> FastString -> DsM CoreExpr
 584 externalFun mod fs
 585   = do
 586       var <- externalVar mod fs
 587       return $ Var var
 588
 589 externalTyCon :: Module -> FastString -> DsM TyCon
 590 externalTyCon mod fs
 591   = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
 592
 593 externalClassTyCon :: Module -> FastString -> DsM TyCon
 594 externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
 595
 596 externalType :: Module -> FastString -> DsM Type
 597 externalType mod fs
 598   = do
 599       tycon <- externalTyCon mod fs
 600       return $ mkTyConApp tycon []
 601
 602 externalClass :: Module -> FastString -> DsM Class
 603 externalClass mod fs
 604   = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
 605
 606 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
 607 primMethod  tycon method (Builtins { dphModules = mods })
 608   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 609   = liftM Just
 610   $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
 611                                     (mkVarOcc $ method ++ suffix)
 612
 613   | otherwise = return Nothing
 614
 615 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
 616 primPArray tycon (Builtins { dphModules = mods })
 617   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 618   = liftM Just
 619   $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
 620                                  (mkTcOcc $ "PArray" ++ suffix)
 621
 622   | otherwise = return Nothing
 623
 624 prim_ty_cons :: NameEnv String
 625 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
 626   where
 627     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
 628