compiler/vectorise/VectBuiltIn.hs

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