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