never executed always true always false
1 {-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
2
3 -- Get definitions for the structs, constants & config etc.
4 #include "Rts.h"
5
6 -- |
7 -- Run-time info table support. This module provides support for
8 -- creating and reading info tables /in the running program/.
9 -- We use the RTS data structures directly via hsc2hs.
10 --
11 module GHCi.InfoTable
12 (
13 mkConInfoTable
14 ) where
15
16 import Prelude hiding (fail) -- See note [Why do we import Prelude here?]
17
18 import Foreign
19 import Foreign.C
20 import GHC.Ptr
21 import GHC.Exts
22 import GHC.Exts.Heap
23 import Data.ByteString (ByteString)
24 import Control.Monad.Fail
25 import qualified Data.ByteString as BS
26 import GHC.Platform.Host (hostPlatformArch)
27 import GHC.Platform.ArchOS
28
29 -- NOTE: Must return a pointer acceptable for use in the header of a closure.
30 -- If tables_next_to_code is enabled, then it must point the 'code' field.
31 -- Otherwise, it should point to the start of the StgInfoTable.
32 mkConInfoTable
33 :: Bool -- TABLES_NEXT_TO_CODE
34 -> Int -- ptr words
35 -> Int -- non-ptr words
36 -> Int -- constr tag
37 -> Int -- pointer tag
38 -> ByteString -- con desc
39 -> IO (Ptr StgInfoTable)
40 -- resulting info table is allocated with allocateExecPage(), and
41 -- should be freed with freeExecPage().
42
43 mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do
44 let entry_addr = interpConstrEntry !! ptrtag
45 code' <- if tables_next_to_code
46 then Just <$> mkJumpToAddr entry_addr
47 else pure Nothing
48 let
49 itbl = StgInfoTable {
50 entry = if tables_next_to_code
51 then Nothing
52 else Just entry_addr,
53 ptrs = fromIntegral ptr_words,
54 nptrs = fromIntegral nonptr_words,
55 tipe = CONSTR,
56 srtlen = fromIntegral tag,
57 code = code'
58 }
59 castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc
60
61
62 -- -----------------------------------------------------------------------------
63 -- Building machine code fragments for a constructor's entry code
64
65 funPtrToInt :: FunPtr a -> Int
66 funPtrToInt (FunPtr a) = I## (addr2Int## a)
67
68 mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
69 mkJumpToAddr a = case hostPlatformArch of
70 ArchSPARC -> pure $
71 -- After some consideration, we'll try this, where
72 -- 0x55555555 stands in for the address to jump to.
73 -- According to rts/include/rts/MachRegs.h, %g3 is very
74 -- likely indeed to be baggable.
75 --
76 -- 0000 07155555 sethi %hi(0x55555555), %g3
77 -- 0004 8610E155 or %g3, %lo(0x55555555), %g3
78 -- 0008 81C0C000 jmp %g3
79 -- 000c 01000000 nop
80
81 let w32 = fromIntegral (funPtrToInt a)
82
83 hi22, lo10 :: Word32 -> Word32
84 lo10 x = x .&. 0x3FF
85 hi22 x = (x `shiftR` 10) .&. 0x3FFFF
86
87 in Right [ 0x07000000 .|. (hi22 w32),
88 0x8610E000 .|. (lo10 w32),
89 0x81C0C000,
90 0x01000000 ]
91
92 ArchPPC -> pure $
93 -- We'll use r12, for no particular reason.
94 -- 0xDEADBEEF stands for the address:
95 -- 3D80DEAD lis r12,0xDEAD
96 -- 618CBEEF ori r12,r12,0xBEEF
97 -- 7D8903A6 mtctr r12
98 -- 4E800420 bctr
99
100 let w32 = fromIntegral (funPtrToInt a)
101 hi16 x = (x `shiftR` 16) .&. 0xFFFF
102 lo16 x = x .&. 0xFFFF
103 in Right [ 0x3D800000 .|. hi16 w32,
104 0x618C0000 .|. lo16 w32,
105 0x7D8903A6, 0x4E800420 ]
106
107 ArchX86 -> pure $
108 -- Let the address to jump to be 0xWWXXYYZZ.
109 -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
110 -- which is
111 -- B8 ZZ YY XX WW FF E0
112
113 let w32 = fromIntegral (funPtrToInt a) :: Word32
114 insnBytes :: [Word8]
115 insnBytes
116 = [0xB8, byte0 w32, byte1 w32,
117 byte2 w32, byte3 w32,
118 0xFF, 0xE0]
119 in
120 Left insnBytes
121
122 ArchX86_64 -> pure $
123 -- Generates:
124 -- jmpq *.L1(%rip)
125 -- .align 8
126 -- .L1:
127 -- .quad <addr>
128 --
129 -- which looks like:
130 -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 <f+0x10>
131 -- with addr at 10.
132 --
133 -- We need a full 64-bit pointer (we can't assume the info table is
134 -- allocated in low memory). Assuming the info pointer is aligned to
135 -- an 8-byte boundary, the addr will also be aligned.
136
137 let w64 = fromIntegral (funPtrToInt a) :: Word64
138 insnBytes :: [Word8]
139 insnBytes
140 = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
141 byte0 w64, byte1 w64, byte2 w64, byte3 w64,
142 byte4 w64, byte5 w64, byte6 w64, byte7 w64]
143 in
144 Left insnBytes
145
146 ArchAlpha -> pure $
147 let w64 = fromIntegral (funPtrToInt a) :: Word64
148 in Right [ 0xc3800000 -- br at, .+4
149 , 0xa79c000c -- ldq at, 12(at)
150 , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well
151 , 0x47ff041f -- nop
152 , fromIntegral (w64 .&. 0x0000FFFF)
153 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
154
155 ArchARM {} -> pure $
156 -- Generates Arm sequence,
157 -- ldr r1, [pc, #0]
158 -- bx r1
159 --
160 -- which looks like:
161 -- 00000000 <.addr-0x8>:
162 -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr>
163 -- 4: 11ff2fe1 bx r1
164 let w32 = fromIntegral (funPtrToInt a) :: Word32
165 in Left [ 0x00, 0x10, 0x9f, 0xe5
166 , 0x11, 0xff, 0x2f, 0xe1
167 , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
168
169 ArchAArch64 {} -> pure $
170 -- Generates:
171 --
172 -- ldr x1, label
173 -- br x1
174 -- label:
175 -- .quad <addr>
176 --
177 -- which looks like:
178 -- 0: 58000041 ldr x1, <label>
179 -- 4: d61f0020 br x1
180 let w64 = fromIntegral (funPtrToInt a) :: Word64
181 in Right [ 0x58000041
182 , 0xd61f0020
183 , fromIntegral w64
184 , fromIntegral (w64 `shiftR` 32) ]
185
186 ArchPPC_64 ELF_V1 -> pure $
187 -- We use the compiler's register r12 to read the function
188 -- descriptor and the linker's register r11 as a temporary
189 -- register to hold the function entry point.
190 -- In the medium code model the function descriptor
191 -- is located in the first two gigabytes, i.e. the address
192 -- of the function pointer is a non-negative 32 bit number.
193 -- 0x0EADBEEF stands for the address of the function pointer:
194 -- 0: 3d 80 0e ad lis r12,0x0EAD
195 -- 4: 61 8c be ef ori r12,r12,0xBEEF
196 -- 8: e9 6c 00 00 ld r11,0(r12)
197 -- c: e8 4c 00 08 ld r2,8(r12)
198 -- 10: 7d 69 03 a6 mtctr r11
199 -- 14: e9 6c 00 10 ld r11,16(r12)
200 -- 18: 4e 80 04 20 bctr
201 let w32 = fromIntegral (funPtrToInt a)
202 hi16 x = (x `shiftR` 16) .&. 0xFFFF
203 lo16 x = x .&. 0xFFFF
204 in Right [ 0x3D800000 .|. hi16 w32,
205 0x618C0000 .|. lo16 w32,
206 0xE96C0000,
207 0xE84C0008,
208 0x7D6903A6,
209 0xE96C0010,
210 0x4E800420]
211
212 ArchPPC_64 ELF_V2 -> pure $
213 -- The ABI requires r12 to point to the function's entry point.
214 -- We use the medium code model where code resides in the first
215 -- two gigabytes, so loading a non-negative32 bit address
216 -- with lis followed by ori is fine.
217 -- 0x0EADBEEF stands for the address:
218 -- 3D800EAD lis r12,0x0EAD
219 -- 618CBEEF ori r12,r12,0xBEEF
220 -- 7D8903A6 mtctr r12
221 -- 4E800420 bctr
222
223 let w32 = fromIntegral (funPtrToInt a)
224 hi16 x = (x `shiftR` 16) .&. 0xFFFF
225 lo16 x = x .&. 0xFFFF
226 in Right [ 0x3D800000 .|. hi16 w32,
227 0x618C0000 .|. lo16 w32,
228 0x7D8903A6, 0x4E800420 ]
229
230 ArchS390X -> pure $
231 -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.
232 -- The following code loads the address into scratch
233 -- register r1 and jumps to it.
234 --
235 -- 0: C0 1E AA BB CC DD llihf %r1,0xAABBCCDD
236 -- 6: C0 19 EE FF GG HH iilf %r1,0xEEFFGGHH
237 -- 12: 07 F1 br %r1
238
239 let w64 = fromIntegral (funPtrToInt a) :: Word64
240 in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,
241 0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
242 0x07, 0xF1 ]
243
244 ArchRISCV64 -> pure $
245 let w64 = fromIntegral (funPtrToInt a) :: Word64
246 in Right [ 0x00000297 -- auipc t0,0
247 , 0x01053283 -- ld t0,16(t0)
248 , 0x00028067 -- jr t0
249 , 0x00000013 -- nop
250 , fromIntegral w64
251 , fromIntegral (w64 `shiftR` 32) ]
252
253 arch ->
254 -- The arch isn't supported. You either need to add your architecture as a
255 -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.
256 fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("
257 ++ show arch ++ ")"
258
259 byte0 :: (Integral w) => w -> Word8
260 byte0 w = fromIntegral w
261
262 byte1, byte2, byte3, byte4, byte5, byte6, byte7
263 :: (Integral w, Bits w) => w -> Word8
264 byte1 w = fromIntegral (w `shiftR` 8)
265 byte2 w = fromIntegral (w `shiftR` 16)
266 byte3 w = fromIntegral (w `shiftR` 24)
267 byte4 w = fromIntegral (w `shiftR` 32)
268 byte5 w = fromIntegral (w `shiftR` 40)
269 byte6 w = fromIntegral (w `shiftR` 48)
270 byte7 w = fromIntegral (w `shiftR` 56)
271
272
273 -- -----------------------------------------------------------------------------
274 -- read & write intfo tables
275
276 -- entry point for direct returns for created constr itbls
277 foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr
278 foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr
279 foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr
280 foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr
281 foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr
282 foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr
283 foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr
284
285 interpConstrEntry :: [EntryFunPtr]
286 interpConstrEntry = [ error "pointer tag 0"
287 , stg_interp_constr1_entry
288 , stg_interp_constr2_entry
289 , stg_interp_constr3_entry
290 , stg_interp_constr4_entry
291 , stg_interp_constr5_entry
292 , stg_interp_constr6_entry
293 , stg_interp_constr7_entry ]
294
295 data StgConInfoTable = StgConInfoTable {
296 conDesc :: Ptr Word8,
297 infoTable :: StgInfoTable
298 }
299
300
301 pokeConItbl
302 :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
303 -> IO ()
304 pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do
305 if tables_next_to_code
306 then do
307 -- Write the offset to the con_desc from the end of the standard InfoTable
308 -- at the first byte.
309 let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
310 (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
311 else do
312 -- Write the con_desc address after the end of the info table.
313 -- Use itblSize because CPP will not pick up PROFILING when calculating
314 -- the offset.
315 pokeByteOff wr_ptr itblSize (conDesc itbl)
316 pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
317
318 sizeOfEntryCode :: MonadFail m => Bool -> m Int
319 sizeOfEntryCode tables_next_to_code
320 | not tables_next_to_code = pure 0
321 | otherwise = do
322 code' <- mkJumpToAddr undefined
323 pure $ case code' of
324 Left xs -> sizeOf (head xs) * length xs
325 Right xs -> sizeOf (head xs) * length xs
326
327 -- Note: Must return proper pointer for use in a closure
328 newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
329 newExecConItbl tables_next_to_code obj con_desc = do
330 sz0 <- sizeOfEntryCode tables_next_to_code
331 let lcon_desc = BS.length con_desc + 1{- null terminator -}
332 -- SCARY
333 -- This size represents the number of bytes in an StgConInfoTable.
334 sz = fromIntegral $ conInfoTableSizeB + sz0
335 -- Note: we need to allocate the conDesc string next to the info
336 -- table, because on a 64-bit platform we reference this string
337 -- with a 32-bit offset relative to the info table, so if we
338 -- allocated the string separately it might be out of range.
339
340 ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do
341 let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
342 , infoTable = obj }
343 pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
344 BS.useAsCStringLen con_desc $ \(src, len) ->
345 copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
346 let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
347 poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
348
349 pure $ if tables_next_to_code
350 then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
351 else castPtrToFunPtr ex_ptr
352
353 -- | Allocate a buffer of a given size, use the given action to fill it with
354 -- data, and mark it as executable. The action is given a writable pointer and
355 -- the executable pointer. Returns a pointer to the executable code.
356 fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)
357
358 #if MIN_VERSION_rts(1,0,2)
359
360 data ExecPage
361
362 foreign import ccall unsafe "allocateExecPage"
363 _allocateExecPage :: IO (Ptr ExecPage)
364
365 foreign import ccall unsafe "freezeExecPage"
366 _freezeExecPage :: Ptr ExecPage -> IO ()
367
368 fillExecBuffer sz cont
369 -- we can only allocate single pages. This assumes a 4k page size which
370 -- isn't strictly correct but is a reasonable conservative lower bound.
371 | sz > 4096 = fail "withExecBuffer: Too large"
372 | otherwise = do
373 pg <- _allocateExecPage
374 cont (castPtr pg) (castPtr pg)
375 _freezeExecPage pg
376 return (castPtr pg)
377
378 #elif MIN_VERSION_rts(1,0,1)
379
380 foreign import ccall unsafe "allocateExec"
381 _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
382
383 foreign import ccall unsafe "flushExec"
384 _flushExec :: CUInt -> Ptr a -> IO ()
385
386 fillExecBuffer sz cont = alloca $ \pcode -> do
387 wr_ptr <- _allocateExec (fromIntegral sz) pcode
388 ex_ptr <- peek pcode
389 cont wr_ptr ex_ptr
390 _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed)
391 return (ex_ptr)
392
393 #else
394
395 #error Sorry, rts versions <= 1.0 are not supported
396
397 #endif
398
399 -- -----------------------------------------------------------------------------
400 -- Constants and config
401
402 wORD_SIZE :: Int
403 wORD_SIZE = (#const SIZEOF_HSINT)
404
405 conInfoTableSizeB :: Int
406 conInfoTableSizeB = wORD_SIZE + itblSize