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.
9 sumTyCon, prodTyCon, prodDataCon,
10 selTy,selReplicate, selPick, selTags, selElements,
11 combinePDVar, scalarZip, closureCtrFun,
14 initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
15 initBuiltinPAs, initBuiltinPRs,
16 initBuiltinBoxedTyCons, initBuiltinScalars,
18 primMethod, primPArray
22 import IfaceEnv ( lookupOrig )
26 import DataCon ( DataCon, dataConName, dataConWorkId )
27 import TyCon ( TyCon, tyConName, tyConDataCons )
28 import Class ( Class, classTyCon )
29 import CoreSyn ( CoreExpr, Expr(..) )
31 import Id ( mkSysLocal )
32 import Name ( Name, getOccString )
36 import TypeRep ( funTyCon )
37 import Type ( Type, mkTyConApp )
39 import TysWiredIn ( unitDataCon,
43 boolTyCon, trueDataCon, falseDataCon,
45 import PrelNames ( word8TyConName, gHC_PARR, gHC_CLASSES )
46 import BasicTypes ( Boxity(..) )
52 import Control.Monad ( liftM, zipWithM )
53 import Data.List ( unzip4 )
56 -- Numbers of things exported by the DPH library.
63 mAX_DPH_COMBINE :: Int
66 mAX_DPH_SCALAR_ARGS :: Int
67 mAX_DPH_SCALAR_ARGS = 3
70 -- | Ids of the modules that contain our DPH builtins.
73 { dph_PArray :: 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
89 -- | The locations of builtins in the current DPH library.
90 dph_Modules :: PackageId -> 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")
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")
108 where mk = mkModule pkg . mkModuleNameFS
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]
116 -- | Information about what builtin stuff to use from the DPH base libraries.
119 { dphModules :: Modules
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
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
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
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
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
165 , liftingContext :: Var -- ^ lc
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.
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.
179 indexBuiltin fn f i bi
180 | inRange (bounds xs) i = xs ! i
181 | otherwise = pprPanic fn (ppr i)
186 -- Projections ----------------------------------------------------------------
187 selTy :: Int -> Builtins -> Type
188 selTy = indexBuiltin "selTy" selTys
190 selReplicate :: Int -> Builtins -> CoreExpr
191 selReplicate = indexBuiltin "selReplicate" selReplicates
193 selPick :: Int -> Builtins -> CoreExpr
194 selPick = indexBuiltin "selPick" selPicks
196 selTags :: Int -> Builtins -> CoreExpr
197 selTags = indexBuiltin "selTags" selTagss
199 selElements :: Int -> Int -> Builtins -> CoreExpr
200 selElements i j = indexBuiltin "selElements" selEls (i,j)
202 sumTyCon :: Int -> Builtins -> TyCon
203 sumTyCon = indexBuiltin "sumTyCon" sumTyCons
205 prodTyCon :: Int -> Builtins -> TyCon
207 | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
208 | otherwise = pprPanic "prodTyCon" (ppr n)
210 prodDataCon :: Int -> Builtins -> DataCon
211 prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of
213 _ -> pprPanic "prodDataCon" (ppr n)
215 combinePDVar :: Int -> Builtins -> Var
216 combinePDVar = indexBuiltin "combinePDVar" combinePDVars
218 scalarZip :: Int -> Builtins -> Var
219 scalarZip = indexBuiltin "scalarZip" scalarZips
221 closureCtrFun :: Int -> Builtins -> Var
222 closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
225 -- Initialisation -------------------------------------------------------------
226 -- | Create the initial map of builtin types and functions.
228 :: PackageId -- ^ package id the builtins are in, eg dph-common
233 mapM_ load dph_Orphans
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
246 closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
248 -- From dph-common:Data.Array.Parallel.Lifted.Repr
249 voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
250 wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
252 -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
253 sel_tys <- mapM (externalType dph_Unboxed)
254 (numbered "Sel" 2 mAX_DPH_SUM)
256 sel_replicates <- mapM (externalFun dph_Unboxed)
257 (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
259 sel_picks <- mapM (externalFun dph_Unboxed)
260 (numbered_hash "pickSel" 2 mAX_DPH_SUM)
262 sel_tags <- mapM (externalFun dph_Unboxed)
263 (numbered "tagsSel" 2 mAX_DPH_SUM)
265 sel_els <- mapM mk_elements
266 [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
268 sum_tcs <- mapM (externalTyCon dph_Repr)
269 (numbered "Sum" 2 mAX_DPH_SUM)
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
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")
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
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
307 liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
312 , parrayTyCon = parrayTyCon
313 , parrayDataCon = parrayDataCon
314 , pdataTyCon = pdataTyCon
316 , paDataCon = paDataCon
317 , preprTyCon = preprTyCon
319 , prDataCon = prDataCon
320 , voidTyCon = voidTyCon
321 , wrapTyCon = wrapTyCon
323 , selReplicates = selReplicates
324 , selPicks = selPicks
325 , selTagss = selTagss
327 , sumTyCons = sumTyCons
328 , closureTyCon = closureTyCon
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
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
356 load get_mod = dsLoadModule doc mod
358 mod = get_mod modules
359 doc = ppr mod <+> ptext (sLit "is a DPH module")
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]]
365 numbered_hash :: String -> Int -> Int -> [FastString]
366 numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]
368 mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
371 v <- externalVar dph_Unboxed
372 $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
373 return ((i,j), Var v)
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 })
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
387 (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
388 (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
390 defaultDataConWorkers :: [DataCon]
391 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
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]]
397 mk_tup n mod name = (tupleCon Boxed n, mod, name)
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
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.
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
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")
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"
442 ++ vars_Ord dph_Prelude_Int
443 ++ vars_Num dph_Prelude_Int
445 ++ vars_Ord dph_Prelude_Word8
446 ++ vars_Num dph_Prelude_Word8
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"
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
460 [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
461 , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
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")
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")
478 mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
481 = [ mk' mod "==" "eqV"
482 , mk' mod "/=" "neqV"
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"
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"
506 = [ mk' mod "/" "divideV"
507 , mk' mod "recip" "recipV"
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"
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"
540 -- | Get a list of names to `TyCon`s in the mock prelude.
541 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
544 -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
545 dft_tcs <- defaultTyCons
546 return $ (tyConName funTyCon, closureTyCon bi)
547 : (parrTyConName, parrayTyCon bi)
550 : (tyConName $ parrayTyCon bi, parrayTyCon bi)
552 : [(tyConName tc, tc) | tc <- dft_tcs]
554 defaultTyCons :: DsM [TyCon]
557 word8 <- dsLookupTyCon word8TyConName
558 return [intTyCon, boolTyCon, doubleTyCon, word8]
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]
565 defaultDataCons :: [DataCon]
566 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
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"))
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"))
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
585 find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
586 | otherwise = pprPanic "Invalid DPH instance" (ppr i)
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
593 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
595 = [(tyConName intPrimTyCon, intTyCon)]
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)
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
609 = [ mk dph_Prelude_Int "div"
610 , mk dph_Prelude_Int "mod"
611 , mk dph_Prelude_Int "sqrt"
613 ++ scalars_Ord dph_Prelude_Int
614 ++ scalars_Num dph_Prelude_Int
616 ++ scalars_Ord dph_Prelude_Word8
617 ++ scalars_Num dph_Prelude_Word8
619 [ mk dph_Prelude_Word8 "div"
620 , mk dph_Prelude_Word8 "mod"
621 , mk dph_Prelude_Word8 "fromInt"
622 , mk dph_Prelude_Word8 "toInt"
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
631 mk mod s = (mod, fsLit s)
652 scalars_Fractional mod
687 -- | Lookup some variable given its name and the module that contains it.
688 externalVar :: Module -> FastString -> DsM Var
690 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
693 -- | Like `externalVar` but wrap the `Var` in a `CoreExpr`
694 externalFun :: Module -> FastString -> DsM CoreExpr
696 = do var <- externalVar mod fs
700 -- | Lookup some `TyCon` given its name and the module that contains it.
701 externalTyCon :: Module -> FastString -> DsM TyCon
703 = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
706 -- | Lookup some `Type` given its name and the module that contains it.
707 externalType :: Module -> FastString -> DsM Type
709 = do tycon <- externalTyCon mod fs
710 return $ mkTyConApp tycon []
713 -- | Lookup some `Class` given its name and the module that contains it.
714 externalClass :: Module -> FastString -> DsM Class
716 = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
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)
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)
729 $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
730 (mkVarOcc $ method ++ suffix)
732 | otherwise = return Nothing
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)
739 $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
740 (mkTcOcc $ "PArray" ++ suffix)
742 | otherwise = return Nothing
744 prim_ty_cons :: NameEnv String
745 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
747 mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)