2 Builtins(..), sumTyCon, prodTyCon, prodDataCon,
3 selTy, selReplicate, selPick, selElements,
4 combinePDVar, scalarZip, closureCtrFun,
5 initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
6 initBuiltinPAs, initBuiltinPRs,
7 initBuiltinBoxedTyCons, initBuiltinScalars,
13 import IfaceEnv ( lookupOrig )
17 import DataCon ( DataCon, dataConName, dataConWorkId )
18 import TyCon ( TyCon, tyConName, tyConDataCons )
19 import Class ( Class, classTyCon )
20 import CoreSyn ( CoreExpr, Expr(..) )
22 import Id ( mkSysLocal )
23 import Name ( Name, getOccString )
27 import TypeRep ( funTyCon )
28 import Type ( Type, mkTyConApp )
30 import TysWiredIn ( unitDataCon,
34 boolTyCon, trueDataCon, falseDataCon,
36 import PrelNames ( word8TyConName, gHC_PARR )
37 import BasicTypes ( Boxity(..) )
43 import Control.Monad ( liftM, zipWithM )
44 import Data.List ( unzip4 )
52 mAX_DPH_COMBINE :: Int
55 mAX_DPH_SCALAR_ARGS :: Int
56 mAX_DPH_SCALAR_ARGS = 3
58 data Modules = Modules {
61 , dph_Closure :: Module
62 , dph_Unboxed :: Module
63 , dph_Instances :: Module
64 , dph_Combinators :: Module
65 , dph_Scalar :: Module
66 , dph_Selector :: Module
67 , dph_Prelude_PArr :: Module
68 , dph_Prelude_Int :: Module
69 , dph_Prelude_Word8 :: Module
70 , dph_Prelude_Double :: Module
71 , dph_Prelude_Bool :: Module
72 , dph_Prelude_Tuple :: Module
75 dph_Modules :: PackageId -> Modules
76 dph_Modules pkg = Modules {
77 dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
78 , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
79 , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
80 , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
81 , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
82 , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
83 , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
84 , dph_Selector = mk (fsLit "Data.Array.Parallel.Lifted.Selector")
86 , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
87 , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
88 , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
89 , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
90 , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
91 , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
94 mk = mkModule pkg . mkModuleNameFS
96 dph_Orphans :: [Modules -> Module]
97 dph_Orphans = [dph_Repr, dph_Instances]
99 data Builtins = Builtins {
100 dphModules :: Modules
101 , parrayTyCon :: TyCon
102 , parrayDataCon :: DataCon
103 , pdataTyCon :: TyCon
105 , paDataCon :: DataCon
106 , preprTyCon :: TyCon
108 , prDataCon :: DataCon
111 , selTys :: Array Int Type
112 , selReplicates :: Array Int CoreExpr
113 , selPicks :: Array Int CoreExpr
114 , selEls :: Array (Int, Int) CoreExpr
115 , sumTyCons :: Array Int TyCon
116 , closureTyCon :: TyCon
123 , liftedClosureVar :: Var
124 , liftedApplyVar :: Var
125 , replicatePDVar :: Var
128 , combinePDVars :: Array Int Var
129 , scalarClass :: Class
130 , scalarZips :: Array Int Var
131 , closureCtrFuns :: Array Int Var
132 , liftingContext :: Var
135 indexBuiltin :: (Ix i, Outputable i) => String -> (Builtins -> Array i a)
136 -> i -> Builtins -> a
137 indexBuiltin fn f i bi
138 | inRange (bounds xs) i = xs ! i
139 | otherwise = pprPanic fn (ppr i)
143 selTy :: Int -> Builtins -> Type
144 selTy = indexBuiltin "selTy" selTys
146 selReplicate :: Int -> Builtins -> CoreExpr
147 selReplicate = indexBuiltin "selReplicate" selReplicates
149 selPick :: Int -> Builtins -> CoreExpr
150 selPick = indexBuiltin "selPick" selPicks
152 selElements :: Int -> Int -> Builtins -> CoreExpr
153 selElements i j = indexBuiltin "selElements" selEls (i,j)
155 sumTyCon :: Int -> Builtins -> TyCon
156 sumTyCon = indexBuiltin "sumTyCon" sumTyCons
158 prodTyCon :: Int -> Builtins -> TyCon
160 | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
161 | otherwise = pprPanic "prodTyCon" (ppr n)
163 prodDataCon :: Int -> Builtins -> DataCon
164 prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of
166 _ -> pprPanic "prodDataCon" (ppr n)
168 combinePDVar :: Int -> Builtins -> Var
169 combinePDVar = indexBuiltin "combinePDVar" combinePDVars
171 scalarZip :: Int -> Builtins -> Var
172 scalarZip = indexBuiltin "scalarZip" scalarZips
174 closureCtrFun :: Int -> Builtins -> Var
175 closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
177 initBuiltins :: PackageId -> DsM Builtins
180 mapM_ load dph_Orphans
181 parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
182 let [parrayDataCon] = tyConDataCons parrayTyCon
183 pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
184 paTyCon <- externalClassTyCon dph_PArray (fsLit "PA")
185 let [paDataCon] = tyConDataCons paTyCon
186 preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
187 prTyCon <- externalClassTyCon dph_PArray (fsLit "PR")
188 let [prDataCon] = tyConDataCons prTyCon
189 closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
191 voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
192 wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
193 sel_tys <- mapM (externalType dph_Selector)
194 (numbered "Sel" 2 mAX_DPH_SUM)
195 sel_replicates <- mapM (externalFun dph_Selector)
196 (numbered "replicate" 2 mAX_DPH_SUM)
197 sel_picks <- mapM (externalFun dph_Selector)
198 (numbered "pick" 2 mAX_DPH_SUM)
199 sel_els <- mapM mk_elements
200 [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
201 sum_tcs <- mapM (externalTyCon dph_Repr)
202 (numbered "Sum" 2 mAX_DPH_SUM)
204 let selTys = listArray (2, mAX_DPH_SUM) sel_tys
205 selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
206 selPicks = listArray (2, mAX_DPH_SUM) sel_picks
207 selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
208 sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
210 voidVar <- externalVar dph_Repr (fsLit "void")
211 pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
212 fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
213 punitVar <- externalVar dph_Repr (fsLit "punit")
214 closureVar <- externalVar dph_Closure (fsLit "closure")
215 applyVar <- externalVar dph_Closure (fsLit "$:")
216 liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
217 liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
218 replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
219 emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
220 packPDVar <- externalVar dph_PArray (fsLit "packPD")
222 combines <- mapM (externalVar dph_PArray)
223 [mkFastString ("combine" ++ show i ++ "PD")
224 | i <- [2..mAX_DPH_COMBINE]]
225 let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
227 scalarClass <- externalClass dph_Scalar (fsLit "Scalar")
228 scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
229 scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
230 scalar_zips <- mapM (externalVar dph_Scalar)
231 (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
232 let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
233 (scalar_map : scalar_zip2 : scalar_zips)
234 closures <- mapM (externalVar dph_Closure)
235 (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
236 let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
238 liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
243 , parrayTyCon = parrayTyCon
244 , parrayDataCon = parrayDataCon
245 , pdataTyCon = pdataTyCon
247 , paDataCon = paDataCon
248 , preprTyCon = preprTyCon
250 , prDataCon = prDataCon
251 , voidTyCon = voidTyCon
252 , wrapTyCon = wrapTyCon
254 , selReplicates = selReplicates
255 , selPicks = selPicks
257 , sumTyCons = sumTyCons
258 , closureTyCon = closureTyCon
260 , pvoidVar = pvoidVar
261 , fromVoidVar = fromVoidVar
262 , punitVar = punitVar
263 , closureVar = closureVar
264 , applyVar = applyVar
265 , liftedClosureVar = liftedClosureVar
266 , liftedApplyVar = liftedApplyVar
267 , replicatePDVar = replicatePDVar
268 , emptyPDVar = emptyPDVar
269 , packPDVar = packPDVar
270 , combinePDVars = combinePDVars
271 , scalarClass = scalarClass
272 , scalarZips = scalarZips
273 , closureCtrFuns = closureCtrFuns
274 , liftingContext = liftingContext
278 dph_PArray = dph_PArray
279 , dph_Repr = dph_Repr
280 , dph_Closure = dph_Closure
281 , dph_Selector = dph_Selector
282 , dph_Scalar = dph_Scalar
286 load get_mod = dsLoadModule doc mod
288 mod = get_mod modules
289 doc = ppr mod <+> ptext (sLit "is a DPH module")
291 numbered :: String -> Int -> Int -> [FastString]
292 numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
294 mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
297 v <- externalVar dph_Selector
298 $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
299 return ((i,j), Var v)
302 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
303 initBuiltinVars (Builtins { dphModules = mods })
305 uvars <- zipWithM externalVar umods ufs
306 vvars <- zipWithM externalVar vmods vfs
307 cvars <- zipWithM externalVar cmods cfs
308 return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
309 ++ zip (map dataConWorkId cons) cvars
312 (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
314 (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
316 defaultDataConWorkers :: [DataCon]
317 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
319 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
320 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
321 = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
323 mk_tup n mod name = (tupleCon Boxed n, mod, name)
325 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
326 preludeVars (Modules { dph_Combinators = dph_Combinators
327 , dph_PArray = dph_PArray
328 , dph_Prelude_Int = dph_Prelude_Int
329 , dph_Prelude_Word8 = dph_Prelude_Word8
330 , dph_Prelude_Double = dph_Prelude_Double
331 , dph_Prelude_Bool = dph_Prelude_Bool
332 , dph_Prelude_PArr = dph_Prelude_PArr
335 mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA")
336 , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
337 , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA")
338 , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
339 , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA")
340 , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
341 , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
342 , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA")
343 , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
344 , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
345 , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA")
346 , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA")
347 , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
349 , mk' dph_Prelude_Int "div" "divV"
350 , mk' dph_Prelude_Int "mod" "modV"
351 , mk' dph_Prelude_Int "sqrt" "sqrtV"
352 , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
353 -- , mk' dph_Prelude_Int "upToP" "upToPA"
355 ++ vars_Ord dph_Prelude_Int
356 ++ vars_Num dph_Prelude_Int
358 ++ vars_Ord dph_Prelude_Word8
359 ++ vars_Num dph_Prelude_Word8
361 [ mk' dph_Prelude_Word8 "div" "divV"
362 , mk' dph_Prelude_Word8 "mod" "modV"
363 , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
364 , mk' dph_Prelude_Word8 "toInt" "toIntV"
367 ++ vars_Ord dph_Prelude_Double
368 ++ vars_Num dph_Prelude_Double
369 ++ vars_Fractional dph_Prelude_Double
370 ++ vars_Floating dph_Prelude_Double
371 ++ vars_RealFrac dph_Prelude_Double
373 [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
374 , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
377 , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
378 , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
379 , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
380 , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
384 mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
386 vars_Ord mod = [mk' mod "==" "eqV"
392 ,mk' mod "min" "minV"
393 ,mk' mod "max" "maxV"
394 ,mk' mod "minimumP" "minimumPA"
395 ,mk' mod "maximumP" "maximumPA"
396 ,mk' mod "minIndexP" "minIndexPA"
397 ,mk' mod "maxIndexP" "maxIndexPA"
400 vars_Num mod = [mk' mod "+" "plusV"
401 ,mk' mod "-" "minusV"
403 ,mk' mod "negate" "negateV"
404 ,mk' mod "abs" "absV"
405 ,mk' mod "sumP" "sumPA"
406 ,mk' mod "productP" "productPA"
409 vars_Fractional mod = [mk' mod "/" "divideV"
410 ,mk' mod "recip" "recipV"
413 vars_Floating mod = [mk' mod "pi" "pi"
414 ,mk' mod "exp" "expV"
415 ,mk' mod "sqrt" "sqrtV"
416 ,mk' mod "log" "logV"
417 ,mk' mod "sin" "sinV"
418 ,mk' mod "tan" "tanV"
419 ,mk' mod "cos" "cosV"
420 ,mk' mod "asin" "asinV"
421 ,mk' mod "atan" "atanV"
422 ,mk' mod "acos" "acosV"
423 ,mk' mod "sinh" "sinhV"
424 ,mk' mod "tanh" "tanhV"
425 ,mk' mod "cosh" "coshV"
426 ,mk' mod "asinh" "asinhV"
427 ,mk' mod "atanh" "atanhV"
428 ,mk' mod "acosh" "acoshV"
430 ,mk' mod "logBase" "logBaseV"
433 vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
434 ,mk' mod "truncate" "truncateV"
435 ,mk' mod "round" "roundV"
436 ,mk' mod "ceiling" "ceilingV"
437 ,mk' mod "floor" "floorV"
440 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
443 -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
444 dft_tcs <- defaultTyCons
445 return $ (tyConName funTyCon, closureTyCon bi)
446 : (parrTyConName, parrayTyCon bi)
449 : (tyConName $ parrayTyCon bi, parrayTyCon bi)
451 : [(tyConName tc, tc) | tc <- dft_tcs]
453 defaultTyCons :: DsM [TyCon]
456 word8 <- dsLookupTyCon word8TyConName
457 return [intTyCon, boolTyCon, doubleTyCon, word8]
459 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
460 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
462 defaultDataCons :: [DataCon]
463 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
465 initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
466 initBuiltinPAs (Builtins { dphModules = mods }) insts
467 = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
469 initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
470 initBuiltinPRs (Builtins { dphModules = mods }) insts
471 = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
473 initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
474 initBuiltinDicts insts cls = map find $ classInstances insts cls
476 find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
477 | otherwise = pprPanic "Invalid DPH instance" (ppr i)
479 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
480 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
482 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
483 builtinBoxedTyCons _ =
484 [(tyConName intPrimTyCon, intTyCon)]
487 initBuiltinScalars :: Builtins -> DsM [Var]
488 initBuiltinScalars bi
489 = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
492 preludeScalars :: Modules -> [(Module, FastString)]
493 preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int
494 , dph_Prelude_Word8 = dph_Prelude_Word8
495 , dph_Prelude_Double = dph_Prelude_Double
498 mk dph_Prelude_Int "div"
499 , mk dph_Prelude_Int "mod"
500 , mk dph_Prelude_Int "sqrt"
502 ++ scalars_Ord dph_Prelude_Int
503 ++ scalars_Num dph_Prelude_Int
505 ++ scalars_Ord dph_Prelude_Word8
506 ++ scalars_Num dph_Prelude_Word8
508 [ mk dph_Prelude_Word8 "div"
509 , mk dph_Prelude_Word8 "mod"
510 , mk dph_Prelude_Word8 "fromInt"
511 , mk dph_Prelude_Word8 "toInt"
514 ++ scalars_Ord dph_Prelude_Double
515 ++ scalars_Num dph_Prelude_Double
516 ++ scalars_Fractional dph_Prelude_Double
517 ++ scalars_Floating dph_Prelude_Double
518 ++ scalars_RealFrac dph_Prelude_Double
520 mk mod s = (mod, fsLit s)
522 scalars_Ord mod = [mk mod "=="
532 scalars_Num mod = [mk mod "+"
539 scalars_Fractional mod = [mk mod "/"
543 scalars_Floating mod = [mk mod "pi"
563 scalars_RealFrac mod = [mk mod "fromInt"
571 externalVar :: Module -> FastString -> DsM Var
573 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
575 externalFun :: Module -> FastString -> DsM CoreExpr
578 var <- externalVar mod fs
581 externalTyCon :: Module -> FastString -> DsM TyCon
583 = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
585 externalClassTyCon :: Module -> FastString -> DsM TyCon
586 externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
588 externalType :: Module -> FastString -> DsM Type
591 tycon <- externalTyCon mod fs
592 return $ mkTyConApp tycon []
594 externalClass :: Module -> FastString -> DsM Class
596 = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
598 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
599 primMethod tycon method (Builtins { dphModules = mods })
600 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
602 $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
603 (mkVarOcc $ method ++ suffix)
605 | otherwise = return Nothing
607 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
608 primPArray tycon (Builtins { dphModules = mods })
609 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
611 $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
612 (mkTcOcc $ "PArray" ++ suffix)
614 | otherwise = return Nothing
616 prim_ty_cons :: NameEnv String
617 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
619 mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)