2 Builtins(..), sumTyCon, prodTyCon,
4 initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
5 initBuiltinPAs, initBuiltinPRs,
6 initBuiltinBoxedTyCons,
12 import IfaceEnv ( lookupOrig )
15 import DataCon ( DataCon, dataConName, dataConWorkId )
16 import TyCon ( TyCon, tyConName, tyConDataCons )
18 import Id ( mkSysLocal )
19 import Name ( Name, getOccString )
23 import TypeRep ( funTyCon )
24 import Type ( Type, mkTyConApp )
26 import TysWiredIn ( unitTyCon, unitDataCon,
28 intTyCon, intTyConName,
29 doubleTyCon, doubleTyConName,
30 boolTyCon, boolTyConName, trueDataCon, falseDataCon,
32 import PrelNames ( word8TyConName, gHC_PARR )
33 import BasicTypes ( Boxity(..) )
39 import Control.Monad ( liftM, zipWithM )
40 import Data.List ( unzip4 )
48 mAX_DPH_COMBINE :: Int
51 data Modules = Modules {
54 , dph_Closure :: Module
55 , dph_Unboxed :: Module
56 , dph_Instances :: Module
57 , dph_Combinators :: Module
58 , dph_Prelude_PArr :: Module
59 , dph_Prelude_Int :: Module
60 , dph_Prelude_Word8 :: Module
61 , dph_Prelude_Double :: Module
62 , dph_Prelude_Bool :: Module
63 , dph_Prelude_Tuple :: Module
66 dph_Modules :: PackageId -> Modules
67 dph_Modules pkg = Modules {
68 dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
69 , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
70 , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
71 , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
72 , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
73 , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
75 , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
76 , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
77 , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
78 , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
79 , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
80 , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
83 mk = mkModule pkg . mkModuleNameFS
86 data Builtins = Builtins {
88 , parrayTyCon :: TyCon
90 , paDataCon :: DataCon
93 , prDataCon :: DataCon
94 , intPrimArrayTy :: Type
97 , enumerationTyCon :: TyCon
98 , sumTyCons :: Array Int TyCon
99 , closureTyCon :: TyCon
102 , mkClosureVar :: Var
103 , applyClosureVar :: Var
104 , mkClosurePVar :: Var
105 , applyClosurePVar :: Var
106 , replicatePAIntPrimVar :: Var
107 , upToPAIntPrimVar :: Var
108 , selectPAIntPrimVar :: Var
109 , truesPABoolPrimVar :: Var
111 , replicatePAVar :: Var
114 , combinePAVars :: Array Int Var
115 , liftingContext :: Var
118 sumTyCon :: Int -> Builtins -> TyCon
120 | n >= 2 && n <= mAX_DPH_SUM = sumTyCons bi ! n
121 | otherwise = pprPanic "sumTyCon" (ppr n)
123 prodTyCon :: Int -> Builtins -> TyCon
125 | n == 1 = wrapTyCon bi
126 | n >= 0 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
127 | otherwise = pprPanic "prodTyCon" (ppr n)
129 combinePAVar :: Int -> Builtins -> Var
131 | n >= 2 && n <= mAX_DPH_COMBINE = combinePAVars bi ! n
132 | otherwise = pprPanic "combinePAVar" (ppr n)
134 initBuiltins :: PackageId -> DsM Builtins
137 parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
138 paTyCon <- externalTyCon dph_PArray (fsLit "PA")
139 let [paDataCon] = tyConDataCons paTyCon
140 preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
141 prTyCon <- externalTyCon dph_PArray (fsLit "PR")
142 let [prDataCon] = tyConDataCons prTyCon
143 intPrimArrayTy <- externalType dph_Unboxed (fsLit "PArray_Int#")
144 closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
146 voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
147 wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
148 enumerationTyCon <- externalTyCon dph_Repr (fsLit "Enumeration")
149 sum_tcs <- mapM (externalTyCon dph_Repr)
150 [mkFastString ("Sum" ++ show i) | i <- [2..mAX_DPH_SUM]]
152 let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
154 voidVar <- externalVar dph_Repr (fsLit "void")
155 mkPRVar <- externalVar dph_PArray (fsLit "mkPR")
156 mkClosureVar <- externalVar dph_Closure (fsLit "mkClosure")
157 applyClosureVar <- externalVar dph_Closure (fsLit "$:")
158 mkClosurePVar <- externalVar dph_Closure (fsLit "mkClosureP")
159 applyClosurePVar <- externalVar dph_Closure (fsLit "$:^")
160 replicatePAIntPrimVar <- externalVar dph_Unboxed (fsLit "replicatePA_Int#")
161 upToPAIntPrimVar <- externalVar dph_Unboxed (fsLit "upToPA_Int#")
162 selectPAIntPrimVar <- externalVar dph_Unboxed (fsLit "selectPA_Int#")
163 truesPABoolPrimVar <- externalVar dph_Unboxed (fsLit "truesPA_Bool#")
164 lengthPAVar <- externalVar dph_PArray (fsLit "lengthPA#")
165 replicatePAVar <- externalVar dph_PArray (fsLit "replicatePA#")
166 emptyPAVar <- externalVar dph_PArray (fsLit "emptyPA")
167 packPAVar <- externalVar dph_PArray (fsLit "packPA#")
169 combines <- mapM (externalVar dph_PArray)
170 [mkFastString ("combine" ++ show i ++ "PA#")
171 | i <- [2..mAX_DPH_COMBINE]]
172 let combinePAVars = listArray (2, mAX_DPH_COMBINE) combines
174 liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
179 , parrayTyCon = parrayTyCon
181 , paDataCon = paDataCon
182 , preprTyCon = preprTyCon
184 , prDataCon = prDataCon
185 , intPrimArrayTy = intPrimArrayTy
186 , voidTyCon = voidTyCon
187 , wrapTyCon = wrapTyCon
188 , enumerationTyCon = enumerationTyCon
189 , sumTyCons = sumTyCons
190 , closureTyCon = closureTyCon
193 , mkClosureVar = mkClosureVar
194 , applyClosureVar = applyClosureVar
195 , mkClosurePVar = mkClosurePVar
196 , applyClosurePVar = applyClosurePVar
197 , replicatePAIntPrimVar = replicatePAIntPrimVar
198 , upToPAIntPrimVar = upToPAIntPrimVar
199 , selectPAIntPrimVar = selectPAIntPrimVar
200 , truesPABoolPrimVar = truesPABoolPrimVar
201 , lengthPAVar = lengthPAVar
202 , replicatePAVar = replicatePAVar
203 , emptyPAVar = emptyPAVar
204 , packPAVar = packPAVar
205 , combinePAVars = combinePAVars
206 , liftingContext = liftingContext
210 dph_PArray = dph_PArray
211 , dph_Repr = dph_Repr
212 , dph_Closure = dph_Closure
213 , dph_Unboxed = dph_Unboxed
218 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
219 initBuiltinVars (Builtins { dphModules = mods })
221 uvars <- zipWithM externalVar umods ufs
222 vvars <- zipWithM externalVar vmods vfs
223 cvars <- zipWithM externalVar cmods cfs
224 return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
225 ++ zip (map dataConWorkId cons) cvars
228 (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
230 (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
232 defaultDataConWorkers :: [DataCon]
233 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
235 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
236 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
237 = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
239 mk_tup n mod name = (tupleCon Boxed n, mod, name)
241 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
242 preludeVars (Modules { dph_Combinators = dph_Combinators
243 , dph_PArray = dph_PArray
244 , dph_Prelude_Int = dph_Prelude_Int
245 , dph_Prelude_Word8 = dph_Prelude_Word8
246 , dph_Prelude_Double = dph_Prelude_Double
247 , dph_Prelude_Bool = dph_Prelude_Bool
248 , dph_Prelude_PArr = dph_Prelude_PArr
251 mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA")
252 , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
253 , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA")
254 , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
255 , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA")
256 , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
257 , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
258 , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA")
259 , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
260 , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
261 , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA")
262 , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA")
263 , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
265 , mk' dph_Prelude_Int "div" "divV"
266 , mk' dph_Prelude_Int "mod" "modV"
267 , mk' dph_Prelude_Int "sqrt" "sqrtV"
268 , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
269 , mk' dph_Prelude_Int "upToP" "upToPA"
271 ++ vars_Ord dph_Prelude_Int
272 ++ vars_Num dph_Prelude_Int
274 ++ vars_Ord dph_Prelude_Word8
275 ++ vars_Num dph_Prelude_Word8
277 [ mk' dph_Prelude_Word8 "div" "divV"
278 , mk' dph_Prelude_Word8 "mod" "modV"
279 , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
280 , mk' dph_Prelude_Word8 "toInt" "toIntV"
283 ++ vars_Ord dph_Prelude_Double
284 ++ vars_Num dph_Prelude_Double
285 ++ vars_Fractional dph_Prelude_Double
286 ++ vars_Floating dph_Prelude_Double
287 ++ vars_RealFrac dph_Prelude_Double
289 [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
290 , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
293 , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
294 , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
295 , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
296 , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
300 mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
302 vars_Ord mod = [mk' mod "==" "eqV"
308 ,mk' mod "min" "minV"
309 ,mk' mod "max" "maxV"
310 ,mk' mod "minimumP" "minimumPA"
311 ,mk' mod "maximumP" "maximumPA"
312 ,mk' mod "minIndexP" "minIndexPA"
313 ,mk' mod "maxIndexP" "maxIndexPA"
316 vars_Num mod = [mk' mod "+" "plusV"
317 ,mk' mod "-" "minusV"
319 ,mk' mod "negate" "negateV"
320 ,mk' mod "abs" "absV"
321 ,mk' mod "sumP" "sumPA"
322 ,mk' mod "productP" "productPA"
325 vars_Fractional mod = [mk' mod "/" "divideV"
326 ,mk' mod "recip" "recipV"
329 vars_Floating mod = [mk' mod "pi" "pi"
330 ,mk' mod "exp" "expV"
331 ,mk' mod "sqrt" "sqrtV"
332 ,mk' mod "log" "logV"
333 ,mk' mod "sin" "sinV"
334 ,mk' mod "tan" "tanV"
335 ,mk' mod "cos" "cosV"
336 ,mk' mod "asin" "asinV"
337 ,mk' mod "atan" "atanV"
338 ,mk' mod "acos" "acosV"
339 ,mk' mod "sinh" "sinhV"
340 ,mk' mod "tanh" "tanhV"
341 ,mk' mod "cosh" "coshV"
342 ,mk' mod "asinh" "asinhV"
343 ,mk' mod "atanh" "atanhV"
344 ,mk' mod "acosh" "acoshV"
346 ,mk' mod "logBase" "logBaseV"
349 vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
350 ,mk' mod "truncate" "truncateV"
351 ,mk' mod "round" "roundV"
352 ,mk' mod "ceiling" "ceilingV"
353 ,mk' mod "floor" "floorV"
356 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
359 -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
360 dft_tcs <- defaultTyCons
361 return $ (tyConName funTyCon, closureTyCon bi)
362 : (parrTyConName, parrayTyCon bi)
365 : (tyConName $ parrayTyCon bi, parrayTyCon bi)
367 : [(tyConName tc, tc) | tc <- dft_tcs]
369 defaultTyCons :: DsM [TyCon]
372 word8 <- dsLookupTyCon word8TyConName
373 return [intTyCon, boolTyCon, doubleTyCon, word8]
375 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
376 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
378 defaultDataCons :: [DataCon]
379 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
381 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
384 dicts <- zipWithM externalVar mods fss
385 return $ zip tcs dicts
387 (tcs, mods, fss) = unzip3 ps
389 initBuiltinPAs :: Builtins -> DsM [(Name, Var)]
390 initBuiltinPAs = initBuiltinDicts . builtinPAs
392 builtinPAs :: Builtins -> [(Name, Module, FastString)]
393 builtinPAs bi@(Builtins { dphModules = mods })
395 mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPA_Clo")
396 , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPA_Void")
397 , mk (tyConName $ parrayTyCon bi) (dph_Instances mods) (fsLit "dPA_PArray")
398 , mk unitTyConName (dph_Instances mods) (fsLit "dPA_Unit")
400 , mk intTyConName (dph_Instances mods) (fsLit "dPA_Int")
401 , mk word8TyConName (dph_Instances mods) (fsLit "dPA_Word8")
402 , mk doubleTyConName (dph_Instances mods) (fsLit "dPA_Double")
403 , mk boolTyConName (dph_Instances mods) (fsLit "dPA_Bool")
407 mk name mod fs = (name, mod, fs)
409 tups = map mk_tup [2..mAX_DPH_PROD]
410 mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
412 (mkFastString $ "dPA_" ++ show n)
414 initBuiltinPRs :: Builtins -> DsM [(Name, Var)]
415 initBuiltinPRs = initBuiltinDicts . builtinPRs
417 builtinPRs :: Builtins -> [(Name, Module, FastString)]
418 builtinPRs bi@(Builtins { dphModules = mods }) =
420 mk (tyConName unitTyCon) (dph_Repr mods) (fsLit "dPR_Unit")
421 , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPR_Void")
422 , mk (tyConName $ wrapTyCon bi) (dph_Repr mods) (fsLit "dPR_Wrap")
423 , mk (tyConName $ enumerationTyCon bi) (dph_Repr mods) (fsLit "dPR_Enumeration")
424 , mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPR_Clo")
427 , mk intTyConName (dph_Instances mods) (fsLit "dPR_Int")
428 , mk word8TyConName (dph_Instances mods) (fsLit "dPR_Word8")
429 , mk doubleTyConName (dph_Instances mods) (fsLit "dPR_Double")
432 ++ map mk_sum [2..mAX_DPH_SUM]
433 ++ map mk_prod [2..mAX_DPH_PROD]
435 mk name mod fs = (name, mod, fs)
437 mk_sum n = (tyConName $ sumTyCon n bi, dph_Repr mods,
438 mkFastString ("dPR_Sum" ++ show n))
440 mk_prod n = (tyConName $ prodTyCon n bi, dph_Repr mods,
441 mkFastString ("dPR_" ++ show n))
443 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
444 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
446 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
447 builtinBoxedTyCons _ =
448 [(tyConName intPrimTyCon, intTyCon)]
450 externalVar :: Module -> FastString -> DsM Var
452 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
454 externalTyCon :: Module -> FastString -> DsM TyCon
456 = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
458 externalType :: Module -> FastString -> DsM Type
461 tycon <- externalTyCon mod fs
462 return $ mkTyConApp tycon []
464 unitTyConName :: Name
465 unitTyConName = tyConName unitTyCon
468 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
469 primMethod tycon method (Builtins { dphModules = mods })
470 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
472 $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
473 (mkVarOcc $ method ++ suffix)
475 | otherwise = return Nothing
477 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
478 primPArray tycon (Builtins { dphModules = mods })
479 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
481 $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
482 (mkTcOcc $ "PArray" ++ suffix)
484 | otherwise = return Nothing
486 prim_ty_cons :: NameEnv String
487 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
489 mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)