2 % (c) The University of Glasgow 2000
4 \section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
7 module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
9 #include "HsVersions.h"
11 import Name ( Name, getName )
12 import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM )
13 import Type ( typePrimRep )
14 import DataCon ( DataCon, dataConRepArgTys )
15 import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
16 import Constants ( mIN_SIZE_NonUpdHeapObject )
17 import ClosureInfo ( mkVirtHeapOffsets )
18 import FastString ( FastString(..) )
20 import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
21 malloc, castPtr, plusPtr, Addr )
22 import Addr ( addrToInt )
23 import Bits ( Bits(..), shiftR )
25 import PrelBase ( Int(..) )
26 import PrelIOBase ( IO(..) )
30 %************************************************************************
32 \subsection{Manufacturing of info tables for DataCons}
34 %************************************************************************
38 type ItblPtr = Ptr StgInfoTable
39 type ItblEnv = FiniteMap Name ItblPtr
42 -- Make info tables for the data decls in this module
43 mkITbls :: [TyCon] -> IO ItblEnv
44 mkITbls [] = return emptyFM
45 mkITbls (tc:tcs) = do itbls <- mkITbl tc
47 return (itbls `plusFM` itbls2)
49 mkITbl :: TyCon -> IO ItblEnv
51 | not (isDataTyCon tc)
53 | n == length dcs -- paranoia; this is an assertion.
54 = make_constr_itbls dcs
56 dcs = tyConDataCons tc
57 n = tyConFamilySize tc
60 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
62 -- Assumes constructors are numbered from zero, not one
63 make_constr_itbls :: [DataCon] -> IO ItblEnv
64 make_constr_itbls cons
66 = do is <- mapM mk_vecret_itbl (zip cons [0..])
69 = do is <- mapM mk_dirret_itbl (zip cons [0..])
72 mk_vecret_itbl (dcon, conNo)
73 = mk_itbl dcon conNo (vecret_entry conNo)
74 mk_dirret_itbl (dcon, conNo)
75 = mk_itbl dcon conNo stg_interp_constr_entry
77 mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
78 mk_itbl dcon conNo entry_addr
79 = let (tot_wds, ptr_wds, _)
80 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
82 nptrs = tot_wds - ptr_wds
84 | ptrs + nptrs >= mIN_SIZE_NonUpdHeapObject = nptrs
85 | otherwise = mIN_SIZE_NonUpdHeapObject - ptrs
87 ptrs = fromIntegral ptrs,
88 nptrs = fromIntegral nptrs_really,
89 tipe = fromIntegral cONSTR,
90 srtlen = fromIntegral conNo,
91 code0 = fromIntegral code0, code1 = fromIntegral code1,
92 code2 = fromIntegral code2, code3 = fromIntegral code3,
93 code4 = fromIntegral code4, code5 = fromIntegral code5,
94 code6 = fromIntegral code6, code7 = fromIntegral code7,
95 code8 = fromIntegral code8, code9 = fromIntegral code9,
96 codeA = fromIntegral codeA, codeB = fromIntegral codeB,
97 codeC = fromIntegral codeC, codeD = fromIntegral codeD,
98 codeE = fromIntegral codeE, codeF = fromIntegral codeF
100 -- Make a piece of code to jump to "entry_label".
101 -- This is the only arch-dependent bit.
102 [code0,code1,code2,code3,code4,code5,code6,code7,
103 code8,code9,codeA,codeB,codeC,codeD,codeE,codeF]
104 = mkJumpToAddr entry_addr
107 --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
108 --putStrLn ("# ptrs of itbl is " ++ show ptrs)
109 --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
111 return (getName dcon, addr `plusPtr` 8)
114 -- Make code which causes a jump to the given address. This is the
115 -- only arch-dependent bit of the itbl story. The returned list is
116 -- 16 elements long, since on sparc 4 words (i.e. 4 insns) are needed.
118 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
119 #include "nativeGen/NCG.h"
121 mkJumpToAddr :: Addr -> [Word8]
123 #if sparc_TARGET_ARCH
124 -- After some consideration, we'll try this, where
125 -- 0x55555555 stands in for the address to jump to.
126 -- According to ghc/includes/MachRegs.h, %g3 is very
127 -- likely indeed to be baggable.
129 -- 0000 07155555 sethi %hi(0x55555555), %g3
130 -- 0004 8610E155 or %g3, %lo(0x55555555), %g3
131 -- 0008 81C0C000 jmp %g3
135 = let w32 = fromIntegral (addrToInt a)
136 insn1 = 0x07000000 .|. (hi22 w32)
137 insn2 = 0x8610E000 .|. (lo10 w32)
142 w2bytes :: Word32 -> [Word8]
144 = map fromIntegral [byte 3 w, byte 2 w, byte 1 w, byte 0 w]
146 hi22, lo10 :: Word32 -> Word32
148 hi22 x = (x `shiftR` 10) .&. 0x3FFFF
151 = concat (map w2bytes [insn1, insn2, insn3, insn4])
157 -- Let the address to jump to be 0xWWXXYYZZ.
158 -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
160 -- B8 ZZ YY XX WW FF E0
162 = let w32 = fromIntegral (addrToInt a)
165 = map fromIntegral (take 16 (
166 [0xB8, byte 0 w32, byte 1 w32,
167 byte 2 w32, byte 3 w32,
169 ++ let nops = 0x90 : nops in nops
176 byte :: Int -> Word32 -> Word32
177 byte 0 w = w .&. 0xFF
178 byte 1 w = (w `shiftR` 8) .&. 0xFF
179 byte 2 w = (w `shiftR` 16) .&. 0xFF
180 byte 3 w = (w `shiftR` 24) .&. 0xFF
183 vecret_entry 0 = stg_interp_constr1_entry
184 vecret_entry 1 = stg_interp_constr2_entry
185 vecret_entry 2 = stg_interp_constr3_entry
186 vecret_entry 3 = stg_interp_constr4_entry
187 vecret_entry 4 = stg_interp_constr5_entry
188 vecret_entry 5 = stg_interp_constr6_entry
189 vecret_entry 6 = stg_interp_constr7_entry
190 vecret_entry 7 = stg_interp_constr8_entry
192 -- entry point for direct returns for created constr itbls
193 foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
194 -- and the 8 vectored ones
195 foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
196 foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
197 foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
198 foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
199 foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
200 foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
201 foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
202 foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
208 -- Ultra-minimalist version specially for constructors
209 data StgInfoTable = StgInfoTable {
214 code0, code1, code2, code3, code4, code5, code6, code7,
215 code8, code9, codeA, codeB, codeC, codeD, codeE, codeF :: Word8
219 instance Storable StgInfoTable where
222 = (sum . map (\f -> f itbl))
223 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
224 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
225 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7,
226 fieldSz code8, fieldSz code9, fieldSz codeA, fieldSz codeB,
227 fieldSz codeC, fieldSz codeD, fieldSz codeE, fieldSz codeF]
230 = (sum . map (\f -> f itbl))
231 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
232 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
233 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7,
234 fieldAl code8, fieldAl code9, fieldAl codeA, fieldAl codeB,
235 fieldAl codeC, fieldAl codeD, fieldAl codeE, fieldAl codeF]
238 = do a1 <- store (ptrs itbl) (castPtr a0)
239 a2 <- store (nptrs itbl) a1
240 a3 <- store (tipe itbl) a2
241 a4 <- store (srtlen itbl) a3
242 a5 <- store (code0 itbl) a4
243 a6 <- store (code1 itbl) a5
244 a7 <- store (code2 itbl) a6
245 a8 <- store (code3 itbl) a7
246 a9 <- store (code4 itbl) a8
247 aA <- store (code5 itbl) a9
248 aB <- store (code6 itbl) aA
249 aC <- store (code7 itbl) aB
250 aD <- store (code8 itbl) aC
251 aE <- store (code9 itbl) aD
252 aF <- store (codeA itbl) aE
253 a10 <- store (codeB itbl) aF
254 a11 <- store (codeC itbl) a10
255 a12 <- store (codeD itbl) a11
256 a13 <- store (codeE itbl) a12
257 a14 <- store (codeF itbl) a13
261 = do (a1, ptrs) <- load (castPtr a0)
262 (a2, nptrs) <- load a1
263 (a3, tipe) <- load a2
264 (a4, srtlen) <- load a3
265 (a5, code0) <- load a4
266 (a6, code1) <- load a5
267 (a7, code2) <- load a6
268 (a8, code3) <- load a7
269 (a9, code4) <- load a8
270 (aA, code5) <- load a9
271 (aB, code6) <- load aA
272 (aC, code7) <- load aB
273 (aD, code8) <- load aC
274 (aE, code9) <- load aD
275 (aF, codeA) <- load aE
276 (a10,codeB) <- load aF
277 (a11,codeC) <- load a10
278 (a12,codeD) <- load a11
279 (a13,codeE) <- load a12
280 (a14,codeF) <- load a13
283 ptrs = ptrs, nptrs = nptrs,
284 srtlen = srtlen, tipe = tipe,
285 code0 = code0, code1 = code1, code2 = code2, code3 = code3,
286 code4 = code4, code5 = code5, code6 = code6, code7 = code7,
287 code8 = code8, code9 = code9, codeA = codeA, codeB = codeB,
288 codeC = codeC, codeD = codeD, codeE = codeE, codeF = codeF
291 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
292 fieldSz sel x = sizeOf (sel x)
294 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
295 fieldAl sel x = alignment (sel x)
297 store :: Storable a => a -> Ptr a -> IO (Ptr b)
298 store x addr = do poke addr x
299 return (castPtr (addr `plusPtr` sizeOf x))
301 load :: Storable a => Ptr a -> IO (Ptr b, a)
302 load addr = do x <- peek addr
303 return (castPtr (addr `plusPtr` sizeOf x), x)