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     ]
 468   where
 469     mk  = (,,,)
 470     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
 471
 472     vars_Ord mod
 473      = [ mk' mod "=="        "eqV"
 474        , mk' mod "/="        "neqV"
 475        , mk' mod "<="        "leV"
 476        , mk' mod "<"         "ltV"
 477        , mk' mod ">="        "geV"
 478        , mk' mod ">"         "gtV"
 479        , mk' mod "min"       "minV"
 480        , mk' mod "max"       "maxV"
 481        , mk' mod "minimumP"  "minimumPA"
 482        , mk' mod "maximumP"  "maximumPA"
 483        , mk' mod "minIndexP" "minIndexPA"
 484        , mk' mod "maxIndexP" "maxIndexPA"
 485        ]
 486
 487     vars_Num mod
 488      = [ mk' mod "+"        "plusV"
 489        , mk' mod "-"        "minusV"
 490        , mk' mod "*"        "multV"
 491        , mk' mod "negate"   "negateV"
 492        , mk' mod "abs"      "absV"
 493        , mk' mod "sumP"     "sumPA"
 494        , mk' mod "productP" "productPA"
 495        ]
 496
 497     vars_Fractional mod
 498      = [ mk' mod "/"     "divideV"
 499        , mk' mod "recip" "recipV"
 500        ]
 501
 502     vars_Floating mod
 503      = [ mk' mod "pi"      "pi"
 504        , mk' mod "exp"     "expV"
 505        , mk' mod "sqrt"    "sqrtV"
 506        , mk' mod "log"     "logV"
 507        , mk' mod "sin"     "sinV"
 508        , mk' mod "tan"     "tanV"
 509        , mk' mod "cos"     "cosV"
 510        , mk' mod "asin"    "asinV"
 511        , mk' mod "atan"    "atanV"
 512        , mk' mod "acos"    "acosV"
 513        , mk' mod "sinh"    "sinhV"
 514        , mk' mod "tanh"    "tanhV"
 515        , mk' mod "cosh"    "coshV"
 516        , mk' mod "asinh"   "asinhV"
 517        , mk' mod "atanh"   "atanhV"
 518        , mk' mod "acosh"   "acoshV"
 519        , mk' mod "**"      "powV"
 520        , mk' mod "logBase" "logBaseV"
 521        ]
 522
 523     vars_RealFrac mod
 524      = [ mk' mod "fromInt"  "fromIntV"
 525        , mk' mod "truncate" "truncateV"
 526        , mk' mod "round"    "roundV"
 527        , mk' mod "ceiling"  "ceilingV"
 528        , mk' mod "floor"    "floorV"
 529        ]
 530
 531
 532 -- | Get a list of names to `TyCon`s in the mock prelude.
 533 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
 534 initBuiltinTyCons bi
 535   = do
 536       -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
 537       dft_tcs <- defaultTyCons
 538       return $ (tyConName funTyCon, closureTyCon bi)
 539              : (parrTyConName,      parrayTyCon bi)
 540
 541              -- FIXME: temporary
 542              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
 543
 544              : [(tyConName tc, tc) | tc <- dft_tcs]
 545
 546 defaultTyCons :: DsM [TyCon]
 547 defaultTyCons
 548   = do
 549       word8 <- dsLookupTyCon word8TyConName
 550       return [intTyCon, boolTyCon, doubleTyCon, word8]
 551
 552
 553 -- | Get a list of names to `DataCon`s in the mock prelude.
 554 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
 555 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
 556
 557 defaultDataCons :: [DataCon]
 558 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
 559
 560
 561 -- | Get the names of all buildin instance functions for the PA class.
 562 initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 563 initBuiltinPAs (Builtins { dphModules = mods }) insts
 564   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
 565
 566
 567 -- | Get the names of all builtin instance functions for the PR class.
 568 initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 569 initBuiltinPRs (Builtins { dphModules = mods }) insts
 570   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
 571
 572
 573 -- | Get the names of all DPH instance functions for this class.
 574 initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
 575 initBuiltinDicts insts cls = map find $ classInstances insts cls
 576   where
 577     find i | [Just tc] <- instanceRoughTcs i    = (tc, instanceDFunId i)
 578            | otherwise                          = pprPanic "Invalid DPH instance" (ppr i)
 579
 580
 581 -- | Get a list of boxed `TyCons` in the mock prelude. This is Int only.
 582 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
 583 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
 584
 585 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
 586 builtinBoxedTyCons _
 587   = [(tyConName intPrimTyCon, intTyCon)]
 588
 589
 590 -- | Get a list of all scalar functions in the mock prelude.
 591 initBuiltinScalars :: Builtins -> DsM [Var]
 592 initBuiltinScalars bi
 593   = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
 594
 595
 596 preludeScalars :: Modules -> [(Module, FastString)]
 597 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
 598                         , dph_Prelude_Word8  = dph_Prelude_Word8
 599                         , dph_Prelude_Double = dph_Prelude_Double
 600                         })
 601   = [ mk dph_Prelude_Int "div"
 602     , mk dph_Prelude_Int "mod"
 603     , mk dph_Prelude_Int "sqrt"
 604     ]
 605     ++ scalars_Ord dph_Prelude_Int
 606     ++ scalars_Num dph_Prelude_Int
 607
 608     ++ scalars_Ord dph_Prelude_Word8
 609     ++ scalars_Num dph_Prelude_Word8
 610     ++
 611     [ mk dph_Prelude_Word8 "div"
 612     , mk dph_Prelude_Word8 "mod"
 613     , mk dph_Prelude_Word8 "fromInt"
 614     , mk dph_Prelude_Word8 "toInt"
 615     ]
 616
 617     ++ scalars_Ord dph_Prelude_Double
 618     ++ scalars_Num dph_Prelude_Double
 619     ++ scalars_Fractional dph_Prelude_Double
 620     ++ scalars_Floating dph_Prelude_Double
 621     ++ scalars_RealFrac dph_Prelude_Double
 622   where
 623     mk mod s = (mod, fsLit s)
 624
 625     scalars_Ord mod
 626      = [ mk mod "=="
 627        , mk mod "/="
 628        , mk mod "<="
 629        , mk mod "<"
 630        , mk mod ">="
 631        , mk mod ">"
 632        , mk mod "min"
 633        , mk mod "max"
 634        ]
 635
 636     scalars_Num mod
 637      = [ mk mod "+"
 638        , mk mod "-"
 639        , mk mod "*"
 640        , mk mod "negate"
 641        , mk mod "abs"
 642        ]
 643
 644     scalars_Fractional mod
 645      = [ mk mod "/"
 646        , mk mod "recip"
 647        ]
 648
 649     scalars_Floating mod
 650      = [ mk mod "pi"
 651        , mk mod "exp"
 652        , mk mod "sqrt"
 653        , mk mod "log"
 654        , mk mod "sin"
 655        , mk mod "tan"
 656        , mk mod "cos"
 657        , mk mod "asin"
 658        , mk mod "atan"
 659        , mk mod "acos"
 660        , mk mod "sinh"
 661        , mk mod "tanh"
 662        , mk mod "cosh"
 663        , mk mod "asinh"
 664        , mk mod "atanh"
 665        , mk mod "acosh"
 666        , mk mod "**"
 667        , mk mod "logBase"
 668        ]
 669
 670     scalars_RealFrac mod
 671      = [ mk mod "fromInt"
 672        , mk mod "truncate"
 673        , mk mod "round"
 674        , mk mod "ceiling"
 675        , mk mod "floor"
 676        ]
 677
 678
 679 -- | Lookup some variable given its name and the module that contains it.
 680 externalVar :: Module -> FastString -> DsM Var
 681 externalVar mod fs
 682   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 683
 684
 685 -- | Like `externalVar` but wrap the `Var` in a `CoreExpr`
 686 externalFun :: Module -> FastString -> DsM CoreExpr
 687 externalFun mod fs
 688  = do var <- externalVar mod fs
 689       return $ Var var
 690
 691
 692 -- | Lookup some `TyCon` given its name and the module that contains it.
 693 externalTyCon :: Module -> FastString -> DsM TyCon
 694 externalTyCon mod fs
 695   = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
 696
 697
 698 -- | Lookup some `Type` given its name and the module that contains it.
 699 externalType :: Module -> FastString -> DsM Type
 700 externalType mod fs
 701  = do  tycon <- externalTyCon mod fs
 702        return $ mkTyConApp tycon []
 703
 704
 705 -- | Lookup some `Class` given its name and the module that contains it.
 706 externalClass :: Module -> FastString -> DsM Class
 707 externalClass mod fs
 708   = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
 709
 710
 711 -- | Like `externalClass`, but get the TyCon of of the class.
 712 externalClassTyCon :: Module -> FastString -> DsM TyCon
 713 externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
 714
 715
 716 -- | Lookup a method function given its name and instance type.
 717 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
 718 primMethod  tycon method (Builtins { dphModules = mods })
 719   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 720   = liftM Just
 721   $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
 722                                     (mkVarOcc $ method ++ suffix)
 723
 724   | otherwise = return Nothing
 725
 726 -- | Lookup the representation type we use for PArrays that contain a given element type.
 727 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
 728 primPArray tycon (Builtins { dphModules = mods })
 729   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
 730   = liftM Just
 731   $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
 732                                  (mkTcOcc $ "PArray" ++ suffix)
 733
 734   | otherwise = return Nothing
 735
 736 prim_ty_cons :: NameEnv String
 737 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
 738   where
 739     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
 740