Add builtin rule to eliminate unnecessary casts in seq
[ghc-hetmet.git] / compiler / vectorise / VectBuiltIn.hs
1 module VectBuiltIn (
2   Builtins(..), sumTyCon, prodTyCon, prodDataCon,
3   selTy, selReplicate, selPick, selTags, selElements,
4   combinePDVar, scalarZip, closureCtrFun,
5   initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
6   initBuiltinPAs, initBuiltinPRs,
7   initBuiltinBoxedTyCons, initBuiltinScalars,
8
9   primMethod, primPArray
10 ) where
11
12 import DsMonad
13 import IfaceEnv        ( lookupOrig )
14 import InstEnv
15
16 import Module
17 import DataCon         ( DataCon, dataConName, dataConWorkId )
18 import TyCon           ( TyCon, tyConName, tyConDataCons )
19 import Class           ( Class, classTyCon )
20 import CoreSyn         ( CoreExpr, Expr(..) )
21 import Var             ( Var )
22 import Id              ( mkSysLocal )
23 import Name            ( Name, getOccString )
24 import NameEnv
25 import OccName
26
27 import TypeRep         ( funTyCon )
28 import Type            ( Type, mkTyConApp )
29 import TysPrim
30 import TysWiredIn      ( unitDataCon,
31                          tupleTyCon, tupleCon,
32                          intTyCon,
33                          doubleTyCon,
34                          boolTyCon, trueDataCon, falseDataCon,
35                          parrTyConName )
36 import PrelNames       ( word8TyConName, gHC_PARR )
37 import BasicTypes      ( Boxity(..) )
38
39 import FastString
40 import Outputable
41
42 import Data.Array
43 import Control.Monad   ( liftM, zipWithM )
44 import Data.List       ( unzip4 )
45
46 mAX_DPH_PROD :: Int
47 mAX_DPH_PROD = 5
48
49 mAX_DPH_SUM :: Int
50 mAX_DPH_SUM = 2
51
52 mAX_DPH_COMBINE :: Int
53 mAX_DPH_COMBINE = 2
54
55 mAX_DPH_SCALAR_ARGS :: Int
56 mAX_DPH_SCALAR_ARGS = 3
57
58 data Modules = Modules {
59                    dph_PArray :: Module
60                  , dph_Repr :: Module
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
73                }
74
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")
85
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")
92   }
93   where
94     mk = mkModule pkg . mkModuleNameFS
95
96 dph_Orphans :: [Modules -> Module]
97 dph_Orphans = [dph_Repr, dph_Instances]
98
99 data Builtins = Builtins {
100                   dphModules       :: Modules
101                 , parrayTyCon      :: TyCon
102                 , parrayDataCon    :: DataCon
103                 , pdataTyCon       :: TyCon
104                 , paTyCon          :: TyCon
105                 , paDataCon        :: DataCon
106                 , preprTyCon       :: TyCon
107                 , prTyCon          :: TyCon
108                 , prDataCon        :: DataCon
109                 , voidTyCon        :: TyCon
110                 , wrapTyCon        :: TyCon
111                 , selTys           :: Array Int Type
112                 , selReplicates    :: Array Int CoreExpr
113                 , selPicks         :: Array Int CoreExpr
114                 , selTagss         :: Array Int CoreExpr
115                 , selEls           :: Array (Int, Int) CoreExpr
116                 , sumTyCons        :: Array Int TyCon
117                 , closureTyCon     :: TyCon
118                 , voidVar          :: Var
119                 , pvoidVar         :: Var
120                 , fromVoidVar      :: Var
121                 , punitVar         :: Var
122                 , closureVar       :: Var
123                 , applyVar         :: Var
124                 , liftedClosureVar :: Var
125                 , liftedApplyVar   :: Var
126                 , replicatePDVar   :: Var
127                 , emptyPDVar       :: Var
128                 , packPDVar        :: Var
129                 , packByTagPDVar   :: Var
130                 , combinePDVars    :: Array Int Var
131                 , scalarClass      :: Class
132                 , scalarZips       :: Array Int Var
133                 , closureCtrFuns   :: Array Int Var
134                 , liftingContext   :: Var
135                 }
136
137 indexBuiltin :: (Ix i, Outputable i) => String -> (Builtins -> Array i a)
138                                         -> i -> Builtins -> a
139 indexBuiltin fn f i bi
140   | inRange (bounds xs) i = xs ! i
141   | otherwise = pprPanic fn (ppr i)
142   where
143     xs = f bi
144
145 selTy :: Int -> Builtins -> Type
146 selTy = indexBuiltin "selTy" selTys
147
148 selReplicate :: Int -> Builtins -> CoreExpr
149 selReplicate = indexBuiltin "selReplicate" selReplicates 
150
151 selPick :: Int -> Builtins -> CoreExpr
152 selPick = indexBuiltin "selPick" selPicks
153
154 selTags :: Int -> Builtins -> CoreExpr
155 selTags = indexBuiltin "selTags" selTagss
156
157 selElements :: Int -> Int -> Builtins -> CoreExpr
158 selElements i j = indexBuiltin "selElements" selEls (i,j)
159
160 sumTyCon :: Int -> Builtins -> TyCon
161 sumTyCon = indexBuiltin "sumTyCon" sumTyCons
162
163 prodTyCon :: Int -> Builtins -> TyCon
164 prodTyCon n _
165   | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n
166   | otherwise = pprPanic "prodTyCon" (ppr n)
167
168 prodDataCon :: Int -> Builtins -> DataCon
169 prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of
170                      [con] -> con
171                      _     -> pprPanic "prodDataCon" (ppr n)
172
173 combinePDVar :: Int -> Builtins -> Var
174 combinePDVar = indexBuiltin "combinePDVar" combinePDVars
175
176 scalarZip :: Int -> Builtins -> Var
177 scalarZip = indexBuiltin "scalarZip" scalarZips
178
179 closureCtrFun :: Int -> Builtins -> Var
180 closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
181
182 initBuiltins :: PackageId -> DsM Builtins
183 initBuiltins pkg
184   = do
185       mapM_ load dph_Orphans
186       parrayTyCon  <- externalTyCon dph_PArray (fsLit "PArray")
187       let [parrayDataCon] = tyConDataCons parrayTyCon
188       pdataTyCon   <- externalTyCon dph_PArray (fsLit "PData")
189       paTyCon      <- externalClassTyCon dph_PArray (fsLit "PA")
190       let [paDataCon] = tyConDataCons paTyCon
191       preprTyCon   <- externalTyCon dph_PArray (fsLit "PRepr")
192       prTyCon      <- externalClassTyCon dph_PArray (fsLit "PR")
193       let [prDataCon] = tyConDataCons prTyCon
194       closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
195
196       voidTyCon    <- externalTyCon dph_Repr (fsLit "Void")
197       wrapTyCon    <- externalTyCon dph_Repr (fsLit "Wrap")
198       sel_tys      <- mapM (externalType dph_Selector)
199                            (numbered "Sel" 2 mAX_DPH_SUM)
200       sel_replicates <- mapM (externalFun dph_Selector)
201                              (numbered "replicate" 2 mAX_DPH_SUM)
202       sel_picks    <- mapM (externalFun dph_Selector)
203                            (numbered "pick" 2 mAX_DPH_SUM)
204       sel_tags     <- mapM (externalFun dph_Selector)
205                            (numbered "tagsSel" 2 mAX_DPH_SUM)
206       sel_els      <- mapM mk_elements
207                            [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
208       sum_tcs      <- mapM (externalTyCon dph_Repr)
209                            (numbered "Sum" 2 mAX_DPH_SUM)
210
211       let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
212           selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
213           selPicks      = listArray (2, mAX_DPH_SUM) sel_picks
214           selTagss      = listArray (2, mAX_DPH_SUM) sel_tags
215           selEls        = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
216           sumTyCons     = listArray (2, mAX_DPH_SUM) sum_tcs
217
218       voidVar          <- externalVar dph_Repr (fsLit "void")
219       pvoidVar         <- externalVar dph_Repr (fsLit "pvoid")
220       fromVoidVar      <- externalVar dph_Repr (fsLit "fromVoid")
221       punitVar         <- externalVar dph_Repr (fsLit "punit")
222       closureVar       <- externalVar dph_Closure (fsLit "closure")
223       applyVar         <- externalVar dph_Closure (fsLit "$:")
224       liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
225       liftedApplyVar   <- externalVar dph_Closure (fsLit "liftedApply")
226       replicatePDVar   <- externalVar dph_PArray (fsLit "replicatePD")
227       emptyPDVar       <- externalVar dph_PArray (fsLit "emptyPD")
228       packPDVar        <- externalVar dph_PArray (fsLit "packPD")
229       packByTagPDVar   <- externalVar dph_PArray (fsLit "packByTagPD")
230
231       combines <- mapM (externalVar dph_PArray)
232                        [mkFastString ("combine" ++ show i ++ "PD")
233                           | i <- [2..mAX_DPH_COMBINE]]
234       let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
235
236       scalarClass <- externalClass dph_Scalar (fsLit "Scalar")
237       scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
238       scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
239       scalar_zips <- mapM (externalVar dph_Scalar)
240                           (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
241       let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
242                                  (scalar_map : scalar_zip2 : scalar_zips)
243       closures <- mapM (externalVar dph_Closure)
244                        (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
245       let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
246
247       liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
248                               newUnique
249
250       return $ Builtins {
251                  dphModules       = modules
252                , parrayTyCon      = parrayTyCon
253                , parrayDataCon    = parrayDataCon
254                , pdataTyCon       = pdataTyCon
255                , paTyCon          = paTyCon
256                , paDataCon        = paDataCon
257                , preprTyCon       = preprTyCon
258                , prTyCon          = prTyCon
259                , prDataCon        = prDataCon
260                , voidTyCon        = voidTyCon
261                , wrapTyCon        = wrapTyCon
262                , selTys           = selTys
263                , selReplicates    = selReplicates
264                , selPicks         = selPicks
265                , selTagss         = selTagss
266                , selEls           = selEls
267                , sumTyCons        = sumTyCons
268                , closureTyCon     = closureTyCon
269                , voidVar          = voidVar
270                , pvoidVar         = pvoidVar
271                , fromVoidVar      = fromVoidVar
272                , punitVar         = punitVar
273                , closureVar       = closureVar
274                , applyVar         = applyVar
275                , liftedClosureVar = liftedClosureVar
276                , liftedApplyVar   = liftedApplyVar
277                , replicatePDVar   = replicatePDVar
278                , emptyPDVar       = emptyPDVar
279                , packPDVar        = packPDVar
280                , packByTagPDVar   = packByTagPDVar
281                , combinePDVars    = combinePDVars
282                , scalarClass      = scalarClass
283                , scalarZips       = scalarZips
284                , closureCtrFuns   = closureCtrFuns
285                , liftingContext   = liftingContext
286                }
287   where
288     modules@(Modules {
289                dph_PArray         = dph_PArray
290              , dph_Repr           = dph_Repr
291              , dph_Closure        = dph_Closure
292              , dph_Selector       = dph_Selector
293              , dph_Scalar         = dph_Scalar
294              })
295       = dph_Modules pkg
296
297     load get_mod = dsLoadModule doc mod
298       where
299         mod = get_mod modules 
300         doc = ppr mod <+> ptext (sLit "is a DPH module")
301
302     numbered :: String -> Int -> Int -> [FastString]
303     numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
304
305     mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
306     mk_elements (i,j)
307       = do
308           v <- externalVar dph_Selector
309              $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
310           return ((i,j), Var v)
311
312
313 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
314 initBuiltinVars (Builtins { dphModules = mods })
315   = do
316       uvars <- zipWithM externalVar umods ufs
317       vvars <- zipWithM externalVar vmods vfs
318       cvars <- zipWithM externalVar cmods cfs
319       return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
320                ++ zip (map dataConWorkId cons) cvars
321                ++ zip uvars vvars
322   where
323     (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
324
325     (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
326
327 defaultDataConWorkers :: [DataCon]
328 defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
329
330 preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
331 preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
332   = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
333   where
334     mk_tup n mod name = (tupleCon Boxed n, mod, name)
335
336 preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
337 preludeVars (Modules { dph_Combinators    = dph_Combinators
338                      , dph_PArray         = dph_PArray
339                      , dph_Prelude_Int    = dph_Prelude_Int
340                      , dph_Prelude_Word8  = dph_Prelude_Word8
341                      , dph_Prelude_Double = dph_Prelude_Double
342                      , dph_Prelude_Bool   = dph_Prelude_Bool 
343                      , dph_Prelude_PArr   = dph_Prelude_PArr
344                      })
345   = [
346       mk gHC_PARR (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
347     , mk gHC_PARR (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
348     , mk gHC_PARR (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
349     , mk gHC_PARR (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
350     , mk gHC_PARR (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
351     , mk gHC_PARR (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
352     , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
353     , mk gHC_PARR (fsLit "!:")         dph_Combinators (fsLit "indexPA")
354     , mk gHC_PARR (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
355     , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
356     , mk gHC_PARR (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
357     , mk gHC_PARR (fsLit "+:+")        dph_Combinators (fsLit "appPA")
358     , mk gHC_PARR (fsLit "emptyP")     dph_PArray (fsLit "emptyPA")
359
360     , mk' dph_Prelude_Int "div"  "divV"
361     , mk' dph_Prelude_Int "mod"  "modV"
362     , mk' dph_Prelude_Int "sqrt" "sqrtV"
363     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
364     -- , mk' dph_Prelude_Int "upToP" "upToPA"
365     ]
366     ++ vars_Ord dph_Prelude_Int
367     ++ vars_Num dph_Prelude_Int
368
369     ++ vars_Ord dph_Prelude_Word8
370     ++ vars_Num dph_Prelude_Word8
371     ++
372     [ mk' dph_Prelude_Word8 "div" "divV"
373     , mk' dph_Prelude_Word8 "mod" "modV"
374     , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
375     , mk' dph_Prelude_Word8 "toInt" "toIntV"
376     ]
377
378     ++ vars_Ord dph_Prelude_Double
379     ++ vars_Num dph_Prelude_Double
380     ++ vars_Fractional dph_Prelude_Double
381     ++ vars_Floating dph_Prelude_Double
382     ++ vars_RealFrac dph_Prelude_Double
383     ++
384     [ mk dph_Prelude_Bool  (fsLit "andP")  dph_Prelude_Bool (fsLit "andPA")
385     , mk dph_Prelude_Bool  (fsLit "orP")  dph_Prelude_Bool (fsLit "orPA")
386
387     -- FIXME: temporary
388     , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
389     , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
390     , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
391     , mk dph_Prelude_PArr (fsLit "combineP")    dph_Combinators (fsLit "combine2PA")
392     ]
393   where
394     mk  = (,,,)
395     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
396
397     vars_Ord mod = [mk' mod "=="  "eqV"
398                    ,mk' mod "/=" "neqV"
399                    ,mk' mod "<="  "leV"
400                    ,mk' mod "<"   "ltV"
401                    ,mk' mod ">="  "geV"
402                    ,mk' mod ">"   "gtV"
403                    ,mk' mod "min" "minV"
404                    ,mk' mod "max" "maxV"
405                    ,mk' mod "minimumP" "minimumPA"
406                    ,mk' mod "maximumP" "maximumPA"
407                    ,mk' mod "minIndexP" "minIndexPA"
408                    ,mk' mod "maxIndexP" "maxIndexPA"
409                    ]
410
411     vars_Num mod = [mk' mod "+"        "plusV"
412                    ,mk' mod "-"        "minusV"
413                    ,mk' mod "*"        "multV"
414                    ,mk' mod "negate"   "negateV"
415                    ,mk' mod "abs"      "absV"
416                    ,mk' mod "sumP"     "sumPA"
417                    ,mk' mod "productP" "productPA"
418                    ]
419
420     vars_Fractional mod = [mk' mod "/"     "divideV"
421                           ,mk' mod "recip" "recipV"
422                           ]
423
424     vars_Floating mod = [mk' mod "pi" "pi"
425                         ,mk' mod "exp" "expV"
426                         ,mk' mod "sqrt" "sqrtV"
427                         ,mk' mod "log" "logV"
428                         ,mk' mod "sin" "sinV"
429                         ,mk' mod "tan" "tanV"
430                         ,mk' mod "cos" "cosV"
431                         ,mk' mod "asin" "asinV"
432                         ,mk' mod "atan" "atanV"
433                         ,mk' mod "acos" "acosV"
434                         ,mk' mod "sinh" "sinhV"
435                         ,mk' mod "tanh" "tanhV"
436                         ,mk' mod "cosh" "coshV"
437                         ,mk' mod "asinh" "asinhV"
438                         ,mk' mod "atanh" "atanhV"
439                         ,mk' mod "acosh" "acoshV"
440                         ,mk' mod "**"    "powV"
441                         ,mk' mod "logBase" "logBaseV"
442                         ]
443
444     vars_RealFrac mod = [mk' mod "fromInt" "fromIntV"
445                         ,mk' mod "truncate" "truncateV"
446                         ,mk' mod "round" "roundV"
447                         ,mk' mod "ceiling" "ceilingV"
448                         ,mk' mod "floor" "floorV"
449                         ]
450
451 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
452 initBuiltinTyCons bi
453   = do
454       -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
455       dft_tcs <- defaultTyCons
456       return $ (tyConName funTyCon, closureTyCon bi)
457              : (parrTyConName,      parrayTyCon bi)
458
459              -- FIXME: temporary
460              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
461
462              : [(tyConName tc, tc) | tc <- dft_tcs]
463
464 defaultTyCons :: DsM [TyCon]
465 defaultTyCons
466   = do
467       word8 <- dsLookupTyCon word8TyConName
468       return [intTyCon, boolTyCon, doubleTyCon, word8]
469
470 initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
471 initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
472
473 defaultDataCons :: [DataCon]
474 defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
475
476 initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
477 initBuiltinPAs (Builtins { dphModules = mods }) insts
478   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
479
480 initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
481 initBuiltinPRs (Builtins { dphModules = mods }) insts
482   = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
483
484 initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
485 initBuiltinDicts insts cls = map find $ classInstances insts cls
486   where
487     find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
488            | otherwise = pprPanic "Invalid DPH instance" (ppr i)
489
490 initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
491 initBuiltinBoxedTyCons = return . builtinBoxedTyCons
492
493 builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
494 builtinBoxedTyCons _ =
495   [(tyConName intPrimTyCon, intTyCon)]
496
497
498 initBuiltinScalars :: Builtins -> DsM [Var]
499 initBuiltinScalars bi
500   = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
501
502
503 preludeScalars :: Modules -> [(Module, FastString)]
504 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
505                         , dph_Prelude_Word8  = dph_Prelude_Word8
506                         , dph_Prelude_Double = dph_Prelude_Double
507                         })
508   = [
509       mk dph_Prelude_Int "div"
510     , mk dph_Prelude_Int "mod"
511     , mk dph_Prelude_Int "sqrt"
512     ]
513     ++ scalars_Ord dph_Prelude_Int
514     ++ scalars_Num dph_Prelude_Int
515
516     ++ scalars_Ord dph_Prelude_Word8
517     ++ scalars_Num dph_Prelude_Word8
518     ++
519     [ mk dph_Prelude_Word8 "div"
520     , mk dph_Prelude_Word8 "mod"
521     , mk dph_Prelude_Word8 "fromInt"
522     , mk dph_Prelude_Word8 "toInt"
523     ]
524
525     ++ scalars_Ord dph_Prelude_Double
526     ++ scalars_Num dph_Prelude_Double
527     ++ scalars_Fractional dph_Prelude_Double
528     ++ scalars_Floating dph_Prelude_Double
529     ++ scalars_RealFrac dph_Prelude_Double
530   where
531     mk mod s = (mod, fsLit s)
532
533     scalars_Ord mod = [mk mod "=="
534                       ,mk mod "/="
535                       ,mk mod "<="
536                       ,mk mod "<"
537                       ,mk mod ">="
538                       ,mk mod ">"
539                       ,mk mod "min"
540                       ,mk mod "max"
541                       ]
542
543     scalars_Num mod = [mk mod "+"
544                       ,mk mod "-"
545                       ,mk mod "*"
546                       ,mk mod "negate"
547                       ,mk mod "abs"
548                       ]
549
550     scalars_Fractional mod = [mk mod "/"
551                              ,mk mod "recip"
552                              ]
553
554     scalars_Floating mod = [mk mod "pi"
555                            ,mk mod "exp"
556                            ,mk mod "sqrt"
557                            ,mk mod "log"
558                            ,mk mod "sin"
559                            ,mk mod "tan"
560                            ,mk mod "cos"
561                            ,mk mod "asin"
562                            ,mk mod "atan"
563                            ,mk mod "acos"
564                            ,mk mod "sinh"
565                            ,mk mod "tanh"
566                            ,mk mod "cosh"
567                            ,mk mod "asinh"
568                            ,mk mod "atanh"
569                            ,mk mod "acosh"
570                            ,mk mod "**"
571                            ,mk mod "logBase"
572                            ]
573
574     scalars_RealFrac mod = [mk mod "fromInt"
575                            ,mk mod "truncate"
576                            ,mk mod "round"
577                            ,mk mod "ceiling"
578                            ,mk mod "floor"
579                            ]
580
581
582 externalVar :: Module -> FastString -> DsM Var
583 externalVar mod fs
584   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
585
586 externalFun :: Module -> FastString -> DsM CoreExpr
587 externalFun mod fs
588   = do
589       var <- externalVar mod fs
590       return $ Var var
591
592 externalTyCon :: Module -> FastString -> DsM TyCon
593 externalTyCon mod fs
594   = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
595
596 externalClassTyCon :: Module -> FastString -> DsM TyCon
597 externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
598
599 externalType :: Module -> FastString -> DsM Type
600 externalType mod fs
601   = do
602       tycon <- externalTyCon mod fs
603       return $ mkTyConApp tycon []
604
605 externalClass :: Module -> FastString -> DsM Class
606 externalClass mod fs
607   = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
608
609 primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
610 primMethod  tycon method (Builtins { dphModules = mods })
611   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
612   = liftM Just
613   $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
614                                     (mkVarOcc $ method ++ suffix)
615
616   | otherwise = return Nothing
617
618 primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
619 primPArray tycon (Builtins { dphModules = mods })
620   | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
621   = liftM Just
622   $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
623                                  (mkTcOcc $ "PArray" ++ suffix)
624
625   | otherwise = return Nothing
626
627 prim_ty_cons :: NameEnv String
628 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
629   where
630     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
631