2 Builtins(..), sumTyCon, prodTyCon,
3 initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs,
8 #include "HsVersions.h"
11 import IfaceEnv ( lookupOrig )
13 import Module ( Module )
14 import DataCon ( DataCon )
15 import TyCon ( TyCon, tyConName, tyConDataCons )
17 import Id ( mkSysLocal )
18 import Name ( Name, getOccString )
22 import TypeRep ( funTyCon )
25 import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
27 import BasicTypes ( Boxity(..) )
33 import Control.Monad ( liftM, zipWithM )
41 data Builtins = Builtins {
44 , paDataCon :: DataCon
47 , prDataCon :: DataCon
48 , parrayIntPrimTyCon :: TyCon
49 , sumTyCons :: Array Int TyCon
50 , closureTyCon :: TyCon
53 , applyClosureVar :: Var
54 , mkClosurePVar :: Var
55 , applyClosurePVar :: Var
57 , replicatePAVar :: Var
60 -- , combinePAVar :: Var
61 , liftingContext :: Var
64 sumTyCon :: Int -> Builtins -> TyCon
66 | n >= 2 && n <= mAX_NDP_SUM = sumTyCons bi ! n
67 | otherwise = pprPanic "sumTyCon" (ppr n)
69 prodTyCon :: Int -> Builtins -> TyCon
71 | n >= 2 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
72 | otherwise = pprPanic "prodTyCon" (ppr n)
74 initBuiltins :: DsM Builtins
77 parrayTyCon <- dsLookupTyCon parrayTyConName
78 paTyCon <- dsLookupTyCon paTyConName
79 let [paDataCon] = tyConDataCons paTyCon
80 preprTyCon <- dsLookupTyCon preprTyConName
81 prTyCon <- dsLookupTyCon prTyConName
82 let [prDataCon] = tyConDataCons prTyCon
83 parrayIntPrimTyCon <- dsLookupTyCon parrayIntPrimTyConName
84 closureTyCon <- dsLookupTyCon closureTyConName
86 sum_tcs <- mapM (lookupExternalTyCon nDP_REPR)
87 [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]]
89 let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs
91 mkPRVar <- dsLookupGlobalId mkPRName
92 mkClosureVar <- dsLookupGlobalId mkClosureName
93 applyClosureVar <- dsLookupGlobalId applyClosureName
94 mkClosurePVar <- dsLookupGlobalId mkClosurePName
95 applyClosurePVar <- dsLookupGlobalId applyClosurePName
96 lengthPAVar <- dsLookupGlobalId lengthPAName
97 replicatePAVar <- dsLookupGlobalId replicatePAName
98 emptyPAVar <- dsLookupGlobalId emptyPAName
99 -- packPAVar <- dsLookupGlobalId packPAName
100 -- combinePAVar <- dsLookupGlobalId combinePAName
102 liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
106 parrayTyCon = parrayTyCon
108 , paDataCon = paDataCon
109 , preprTyCon = preprTyCon
111 , prDataCon = prDataCon
112 , parrayIntPrimTyCon = parrayIntPrimTyCon
113 , sumTyCons = sumTyCons
114 , closureTyCon = closureTyCon
116 , mkClosureVar = mkClosureVar
117 , applyClosureVar = applyClosureVar
118 , mkClosurePVar = mkClosurePVar
119 , applyClosurePVar = applyClosurePVar
120 , lengthPAVar = lengthPAVar
121 , replicatePAVar = replicatePAVar
122 , emptyPAVar = emptyPAVar
123 -- , packPAVar = packPAVar
124 -- , combinePAVar = combinePAVar
125 , liftingContext = liftingContext
128 initBuiltinTyCons :: DsM [(Name, TyCon)]
132 return (zip origs vects)
134 (origs, vs) = unzip builtinTyCons
136 builtinTyCons :: [(Name, DsM TyCon)]
137 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
139 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
142 dicts <- zipWithM lookupExternalVar mods fss
143 return $ zip tcs dicts
145 (tcs, mods, fss) = unzip3 ps
147 initBuiltinPAs = initBuiltinDicts builtinPAs
149 builtinPAs :: [(Name, Module, FastString)]
151 mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo")
152 , mk unitTyConName nDP_INSTANCES FSLIT("dPA_Unit")
154 , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int")
158 mk name mod fs = (name, mod, fs)
160 tups = map mk_tup [2..3]
161 mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
163 (mkFastString $ "dPA_" ++ show n)
165 initBuiltinPRs = initBuiltinDicts . builtinPRs
167 builtinPRs :: Builtins -> [(Name, Module, FastString)]
170 mk (tyConName unitTyCon) nDP_REPR FSLIT("dPR_Unit")
171 , mk closureTyConName nDP_CLOSURE FSLIT("dPR_Clo")
174 , mk intTyConName nDP_INSTANCES FSLIT("dPR_Int")
177 ++ map mk_sum [2..mAX_NDP_SUM]
178 ++ map mk_prod [2..mAX_NDP_PROD]
180 mk name mod fs = (name, mod, fs)
182 mk_sum n = (tyConName $ sumTyCon n bi, nDP_REPR,
183 mkFastString ("dPR_Sum" ++ show n))
185 mk_prod n = (tyConName $ prodTyCon n bi, nDP_REPR,
186 mkFastString ("dPR_" ++ show n))
188 lookupExternalVar :: Module -> FastString -> DsM Var
189 lookupExternalVar mod fs
190 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
192 lookupExternalTyCon :: Module -> FastString -> DsM TyCon
193 lookupExternalTyCon mod fs
194 = dsLookupTyCon =<< lookupOrig mod (mkOccNameFS tcName fs)
196 unitTyConName = tyConName unitTyCon
199 primMethod :: TyCon -> String -> DsM (Maybe Var)
200 primMethod tycon method
201 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
203 $ dsLookupGlobalId =<< lookupOrig nDP_PRIM (mkVarOcc $ method ++ suffix)
205 | otherwise = return Nothing
207 primPArray :: TyCon -> DsM (Maybe TyCon)
209 | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
211 $ dsLookupTyCon =<< lookupOrig nDP_PRIM (mkOccName tcName $ "PArray" ++ suffix)
213 | otherwise = return Nothing
215 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
217 mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)