3 initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
6 #include "HsVersions.h"
9 import IfaceEnv ( lookupOrig )
11 import Module ( Module )
12 import DataCon ( DataCon )
13 import TyCon ( TyCon, tyConName, tyConDataCons )
15 import Id ( mkSysLocal )
17 import OccName ( mkVarOccFS )
19 import TypeRep ( funTyCon )
20 import TysPrim ( intPrimTy )
21 import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
23 import BasicTypes ( Boxity(..) )
27 import Control.Monad ( liftM, zipWithM )
29 data Builtins = Builtins {
32 , paDataCon :: DataCon
35 , prDataCon :: DataCon
37 , embedDataCon :: DataCon
39 , crossDataCon :: DataCon
41 , leftDataCon :: DataCon
42 , rightDataCon :: DataCon
43 , closureTyCon :: TyCon
45 , applyClosureVar :: Var
46 , mkClosurePVar :: Var
47 , applyClosurePVar :: Var
49 , replicatePAVar :: Var
52 -- , combinePAVar :: Var
54 , liftingContext :: Var
57 initBuiltins :: DsM Builtins
60 parrayTyCon <- dsLookupTyCon parrayTyConName
61 paTyCon <- dsLookupTyCon paTyConName
62 let [paDataCon] = tyConDataCons paTyCon
63 preprTyCon <- dsLookupTyCon preprTyConName
64 prTyCon <- dsLookupTyCon prTyConName
65 let [prDataCon] = tyConDataCons prTyCon
66 embedTyCon <- dsLookupTyCon embedTyConName
67 let [embedDataCon] = tyConDataCons embedTyCon
68 crossTyCon <- dsLookupTyCon ndpCrossTyConName
69 let [crossDataCon] = tyConDataCons crossTyCon
70 plusTyCon <- dsLookupTyCon ndpPlusTyConName
71 let [leftDataCon, rightDataCon] = tyConDataCons plusTyCon
72 closureTyCon <- dsLookupTyCon closureTyConName
74 mkClosureVar <- dsLookupGlobalId mkClosureName
75 applyClosureVar <- dsLookupGlobalId applyClosureName
76 mkClosurePVar <- dsLookupGlobalId mkClosurePName
77 applyClosurePVar <- dsLookupGlobalId applyClosurePName
78 lengthPAVar <- dsLookupGlobalId lengthPAName
79 replicatePAVar <- dsLookupGlobalId replicatePAName
80 emptyPAVar <- dsLookupGlobalId emptyPAName
81 -- packPAVar <- dsLookupGlobalId packPAName
82 -- combinePAVar <- dsLookupGlobalId combinePAName
83 intEqPAVar <- dsLookupGlobalId intEqPAName
85 liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
89 parrayTyCon = parrayTyCon
91 , paDataCon = paDataCon
92 , preprTyCon = preprTyCon
94 , prDataCon = prDataCon
95 , embedTyCon = embedTyCon
96 , embedDataCon = embedDataCon
97 , crossTyCon = crossTyCon
98 , crossDataCon = crossDataCon
99 , plusTyCon = plusTyCon
100 , leftDataCon = leftDataCon
101 , rightDataCon = rightDataCon
102 , closureTyCon = closureTyCon
103 , mkClosureVar = mkClosureVar
104 , applyClosureVar = applyClosureVar
105 , mkClosurePVar = mkClosurePVar
106 , applyClosurePVar = applyClosurePVar
107 , lengthPAVar = lengthPAVar
108 , replicatePAVar = replicatePAVar
109 , emptyPAVar = emptyPAVar
110 -- , packPAVar = packPAVar
111 -- , combinePAVar = combinePAVar
112 , intEqPAVar = intEqPAVar
113 , liftingContext = liftingContext
116 initBuiltinTyCons :: DsM [(Name, TyCon)]
120 return (zip origs vects)
122 (origs, vs) = unzip builtinTyCons
124 builtinTyCons :: [(Name, DsM TyCon)]
125 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
127 initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
130 dicts <- zipWithM lookupExternalVar mods fss
131 return $ zip tcs dicts
133 (tcs, mods, fss) = unzip3 ps
135 initBuiltinPAs = initBuiltinDicts builtinPAs
137 builtinPAs :: [(Name, Module, FastString)]
139 mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo")
140 , mk unitTyConName nDP_PARRAY FSLIT("dPA_Unit")
142 , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int")
146 mk name mod fs = (name, mod, fs)
148 tups = map mk_tup [2..3]
149 mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
151 (mkFastString $ "dPA_" ++ show n)
153 initBuiltinPRs = initBuiltinDicts builtinPRs
155 builtinPRs :: [(Name, Module, FastString)]
157 mk (tyConName unitTyCon) nDP_PARRAY FSLIT("dPR_Unit")
158 , mk ndpCrossTyConName nDP_PARRAY FSLIT("dPR_Cross")
159 , mk ndpPlusTyConName nDP_PARRAY FSLIT("dPR_Plus")
160 , mk embedTyConName nDP_PARRAY FSLIT("dPR_Embed")
161 , mk closureTyConName nDP_CLOSURE FSLIT("dPR_Clo")
164 , mk intTyConName nDP_INSTANCES FSLIT("dPR_Int")
167 mk name mod fs = (name, mod, fs)
169 lookupExternalVar :: Module -> FastString -> DsM Var
170 lookupExternalVar mod fs
171 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
173 unitTyConName = tyConName unitTyCon