3 initBuiltins, initBuiltinTyCons, initBuiltinPAs
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 initBuiltinPAs :: DsM [(Name, Var)]
130 pas <- zipWithM lookupExternalVar mods fss
133 (tcs, mods, fss) = unzip3 builtinPAs
135 builtinPAs :: [(Name, Module, FastString)]
137 mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo")
138 , mk (tyConName unitTyCon) nDP_PARRAY FSLIT("dPA_Unit")
140 , temporary intTyConName FSLIT("dPA_Int")
144 mk name mod fs = (name, mod, fs)
146 temporary name fs = (name, nDP_INSTANCES, fs)
148 tups = map mk_tup [2..3]
149 mk_tup n = temporary (tyConName $ tupleTyCon Boxed n)
150 (mkFastString $ "dPA_" ++ show n)
152 lookupExternalVar :: Module -> FastString -> DsM Var
153 lookupExternalVar mod fs
154 = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)