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