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 ( 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_Double :: Module
61 , dph_Prelude_Bool :: Module
62 , dph_Prelude_Tuple :: Module
65 dph_Modules :: PackageId -> Modules
66 dph_Modules pkg = Modules {
67 dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
68 , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
69 , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
70 , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
71 , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
72 , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
74 , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
75 , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
76 , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
77 , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
78 , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
81 mk = mkModule pkg . mkModuleNameFS
84 data Builtins = Builtins {
86 , parrayTyCon :: TyCon
88 , paDataCon :: DataCon
91 , prDataCon :: DataCon
92 , intPrimArrayTy :: Type
95 , enumerationTyCon :: TyCon
96 , sumTyCons :: Array Int TyCon
97 , closureTyCon :: TyCon
100 , mkClosureVar :: Var
101 , applyClosureVar :: Var
102 , mkClosurePVar :: Var
103 , applyClosurePVar :: Var
104 , replicatePAIntPrimVar :: Var
105 , upToPAIntPrimVar :: Var
106 , selectPAIntPrimVar :: Var
107 , truesPABoolPrimVar :: Var
109 , replicatePAVar :: Var
112 , combinePAVars :: Array Int Var
113 , liftingContext :: Var
116 sumTyCon :: Int -> Builtins -> TyCon
118 | n >= 2 && n <= mAX_DPH_SUM = sumTyCons bi ! n
119 | otherwise = pprPanic "sumTyCon" (ppr n)
121 prodTyCon :: Int -> Builtins -> TyCon
123 | n == 1 = wrapTyCon bi
124 | n >= 0 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
125 | otherwise = pprPanic "prodTyCon" (ppr n)
127 combinePAVar :: Int -> Builtins -> Var
129 | n >= 2 && n <= mAX_DPH_COMBINE = combinePAVars bi ! n
130 | otherwise = pprPanic "combinePAVar" (ppr n)
132 initBuiltins :: PackageId -> DsM Builtins
135 parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
136 paTyCon <- externalTyCon dph_PArray (fsLit "PA")
137 let [paDataCon] = tyConDataCons paTyCon
138 preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
139 prTyCon <- externalTyCon dph_PArray (fsLit "PR")
140 let [prDataCon] = tyConDataCons prTyCon
141 intPrimArrayTy <- externalType dph_Unboxed (fsLit "PArray_Int#")
142 closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
144 voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
145 wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
146 enumerationTyCon <- externalTyCon dph_Repr (fsLit "Enumeration")
147 sum_tcs <- mapM (externalTyCon dph_Repr)
148 [mkFastString ("Sum" ++ show i) | i <- [2..mAX_DPH_SUM]]
150 let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
152 voidVar <- externalVar dph_Repr (fsLit "void")
153 mkPRVar <- externalVar dph_PArray (fsLit "mkPR")
154 mkClosureVar <- externalVar dph_Closure (fsLit "mkClosure")
155 applyClosureVar <- externalVar dph_Closure (fsLit "$:")
156 mkClosurePVar <- externalVar dph_Closure (fsLit "mkClosureP")
157 applyClosurePVar <- externalVar dph_Closure (fsLit "$:^")
158 replicatePAIntPrimVar <- externalVar dph_Unboxed (fsLit "replicatePA_Int#")
159 upToPAIntPrimVar <- externalVar dph_Unboxed (fsLit "upToPA_Int#")
160 selectPAIntPrimVar <- externalVar dph_Unboxed (fsLit "selectPA_Int#")
161 truesPABoolPrimVar <- externalVar dph_Unboxed (fsLit "truesPA_Bool#")
162 lengthPAVar <- externalVar dph_PArray (fsLit "lengthPA#")
163 replicatePAVar <- externalVar dph_PArray (fsLit "replicatePA#")
164 emptyPAVar <- externalVar dph_PArray (fsLit "emptyPA")
165 packPAVar <- externalVar dph_PArray (fsLit "packPA#")
167 combines <- mapM (externalVar dph_PArray)
168 [mkFastString ("combine" ++ show i ++ "PA#")
169 | i <- [2..mAX_DPH_COMBINE]]
170 let combinePAVars = listArray (2, mAX_DPH_COMBINE) combines
172 liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
177 , parrayTyCon = parrayTyCon
179 , paDataCon = paDataCon
180 , preprTyCon = preprTyCon
182 , prDataCon = prDataCon
183 , intPrimArrayTy = intPrimArrayTy
184 , voidTyCon = voidTyCon
185 , wrapTyCon = wrapTyCon
186 , enumerationTyCon = enumerationTyCon
187 , sumTyCons = sumTyCons
188 , closureTyCon = closureTyCon
191 , mkClosureVar = mkClosureVar
192 , applyClosureVar = applyClosureVar
193 , mkClosurePVar = mkClosurePVar
194 , applyClosurePVar = applyClosurePVar
195 , replicatePAIntPrimVar = replicatePAIntPrimVar
196 , upToPAIntPrimVar = upToPAIntPrimVar
197 , selectPAIntPrimVar = selectPAIntPrimVar
198 , truesPABoolPrimVar = truesPABoolPrimVar
199 , lengthPAVar = lengthPAVar
200 , replicatePAVar = replicatePAVar
201 , emptyPAVar = emptyPAVar
202 , packPAVar = packPAVar
203 , combinePAVars = combinePAVars
204 , liftingContext = liftingContext
208 dph_PArray = dph_PArray
209 , dph_Repr = dph_Repr
210 , dph_Closure = dph_Closure
211 , dph_Unboxed = dph_Unboxed
216 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
217 initBuiltinVars (Builtins { dphModules = mods })
219 uvars <- zipWithM externalVar umods ufs
220 vvars <- zipWithM externalVar vmods vfs
221 cvars <- zipWithM externalVar cmods cfs
222 return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
223 ++ zip (map dataConWorkId cons) cvars
226 (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
228 (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
230 defaultDataConWorkers :: [DataCon]
231 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
233 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
234 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
235 = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
237 mk_tup n mod name = (tupleCon Boxed n, mod, name)
239 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
240 preludeVars (Modules { dph_Combinators = dph_Combinators
241 , dph_PArray = dph_PArray
242 , dph_Prelude_Int = dph_Prelude_Int
243 , dph_Prelude_Double = dph_Prelude_Double
244 , dph_Prelude_Bool = dph_Prelude_Bool
245 , dph_Prelude_PArr = dph_Prelude_PArr
248 mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA")
249 , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
250 , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA")
251 , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
252 , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA")
253 , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
254 , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
255 , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA")
256 , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
257 , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
258 , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA")
259 , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA")
260 , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
262 , mk dph_Prelude_Int (fsLit "plus") dph_Prelude_Int (fsLit "plusV")
263 , mk dph_Prelude_Int (fsLit "minus") dph_Prelude_Int (fsLit "minusV")
264 , mk dph_Prelude_Int (fsLit "mult") dph_Prelude_Int (fsLit "multV")
265 , mk dph_Prelude_Int (fsLit "intDiv") dph_Prelude_Int (fsLit "intDivV")
266 , mk dph_Prelude_Int (fsLit "intMod") dph_Prelude_Int (fsLit "intModV")
267 , mk dph_Prelude_Int (fsLit "intSquareRoot") dph_Prelude_Int (fsLit "intSquareRootV")
268 , mk dph_Prelude_Int (fsLit "intSumP") dph_Prelude_Int (fsLit "intSumPA")
269 , mk dph_Prelude_Int (fsLit "enumFromToP") dph_Prelude_Int (fsLit "enumFromToPA")
270 , mk dph_Prelude_Int (fsLit "upToP") dph_Prelude_Int (fsLit "upToPA")
272 , mk dph_Prelude_Int (fsLit "eq") dph_Prelude_Int (fsLit "eqV")
273 , mk dph_Prelude_Int (fsLit "neq") dph_Prelude_Int (fsLit "neqV")
274 , mk dph_Prelude_Int (fsLit "le") dph_Prelude_Int (fsLit "leV")
275 , mk dph_Prelude_Int (fsLit "lt") dph_Prelude_Int (fsLit "ltV")
276 , mk dph_Prelude_Int (fsLit "ge") dph_Prelude_Int (fsLit "geV")
277 , mk dph_Prelude_Int (fsLit "gt") dph_Prelude_Int (fsLit "gtV")
279 , mk dph_Prelude_Double (fsLit "plus") dph_Prelude_Double (fsLit "plusV")
280 , mk dph_Prelude_Double (fsLit "minus") dph_Prelude_Double (fsLit "minusV")
281 , mk dph_Prelude_Double (fsLit "mult") dph_Prelude_Double (fsLit "multV")
282 , mk dph_Prelude_Double (fsLit "divide") dph_Prelude_Double (fsLit "divideV")
283 , mk dph_Prelude_Double (fsLit "squareRoot") dph_Prelude_Double (fsLit "squareRootV")
284 , mk dph_Prelude_Double (fsLit "doubleSumP") dph_Prelude_Double (fsLit "doubleSumPA")
285 , mk dph_Prelude_Double (fsLit "minIndexP")
286 dph_Prelude_Double (fsLit "minIndexPA")
287 , mk dph_Prelude_Double (fsLit "maxIndexP")
288 dph_Prelude_Double (fsLit "maxIndexPA")
290 , mk dph_Prelude_Double (fsLit "eq") dph_Prelude_Double (fsLit "eqV")
291 , mk dph_Prelude_Double (fsLit "neq") dph_Prelude_Double (fsLit "neqV")
292 , mk dph_Prelude_Double (fsLit "le") dph_Prelude_Double (fsLit "leV")
293 , mk dph_Prelude_Double (fsLit "lt") dph_Prelude_Double (fsLit "ltV")
294 , mk dph_Prelude_Double (fsLit "ge") dph_Prelude_Double (fsLit "geV")
295 , mk dph_Prelude_Double (fsLit "gt") dph_Prelude_Double (fsLit "gtV")
297 , mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
298 , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
301 , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
302 , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
303 , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
304 , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
309 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
312 -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
313 return $ (tyConName funTyCon, closureTyCon bi)
314 : (parrTyConName, parrayTyCon bi)
317 : (tyConName $ parrayTyCon bi, parrayTyCon bi)
319 : [(tyConName tc, tc) | tc <- defaultTyCons]
321 defaultTyCons :: [TyCon]
322 defaultTyCons = [intTyCon, boolTyCon, doubleTyCon]
324 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
325 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
327 defaultDataCons :: [DataCon]
328 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
330 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
333 dicts <- zipWithM externalVar mods fss
334 return $ zip tcs dicts
336 (tcs, mods, fss) = unzip3 ps
338 initBuiltinPAs :: Builtins -> DsM [(Name, Var)]
339 initBuiltinPAs = initBuiltinDicts . builtinPAs
341 builtinPAs :: Builtins -> [(Name, Module, FastString)]
342 builtinPAs bi@(Builtins { dphModules = mods })
344 mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPA_Clo")
345 , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPA_Void")
346 , mk (tyConName $ parrayTyCon bi) (dph_Instances mods) (fsLit "dPA_PArray")
347 , mk unitTyConName (dph_Instances mods) (fsLit "dPA_Unit")
349 , mk intTyConName (dph_Instances mods) (fsLit "dPA_Int")
350 , mk doubleTyConName (dph_Instances mods) (fsLit "dPA_Double")
351 , mk boolTyConName (dph_Instances mods) (fsLit "dPA_Bool")
355 mk name mod fs = (name, mod, fs)
357 tups = map mk_tup [2..mAX_DPH_PROD]
358 mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
360 (mkFastString $ "dPA_" ++ show n)
362 initBuiltinPRs :: Builtins -> DsM [(Name, Var)]
363 initBuiltinPRs = initBuiltinDicts . builtinPRs
365 builtinPRs :: Builtins -> [(Name, Module, FastString)]
366 builtinPRs bi@(Builtins { dphModules = mods }) =
368 mk (tyConName unitTyCon) (dph_Repr mods) (fsLit "dPR_Unit")
369 , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPR_Void")
370 , mk (tyConName $ wrapTyCon bi) (dph_Repr mods) (fsLit "dPR_Wrap")
371 , mk (tyConName $ enumerationTyCon bi) (dph_Repr mods) (fsLit "dPR_Enumeration")
372 , mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPR_Clo")
375 , mk intTyConName (dph_Instances mods) (fsLit "dPR_Int")
376 , mk doubleTyConName (dph_Instances mods) (fsLit "dPR_Double")
379 ++ map mk_sum [2..mAX_DPH_SUM]
380 ++ map mk_prod [2..mAX_DPH_PROD]
382 mk name mod fs = (name, mod, fs)
384 mk_sum n = (tyConName $ sumTyCon n bi, dph_Repr mods,
385 mkFastString ("dPR_Sum" ++ show n))
387 mk_prod n = (tyConName $ prodTyCon n bi, dph_Repr mods,
388 mkFastString ("dPR_" ++ show n))
390 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
391 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
393 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
394 builtinBoxedTyCons _ =
395 [(tyConName intPrimTyCon, intTyCon)]
397 externalVar :: Module -> FastString -> DsM Var
399 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
401 externalTyCon :: Module -> FastString -> DsM TyCon
403 = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
405 externalType :: Module -> FastString -> DsM Type
408 tycon <- externalTyCon mod fs
409 return $ mkTyConApp tycon []
411 unitTyConName :: Name
412 unitTyConName = tyConName unitTyCon
415 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
416 primMethod tycon method (Builtins { dphModules = mods })
417 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
419 $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
420 (mkVarOcc $ method ++ suffix)
422 | otherwise = return Nothing
424 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
425 primPArray tycon (Builtins { dphModules = mods })
426 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
428 $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
429 (mkTcOcc $ "PArray" ++ suffix)
431 | otherwise = return Nothing
433 prim_ty_cons :: NameEnv String
434 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
436 mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)