7e1f8bcf7146c50d718583fdc11b69c787dd624c
[ghc.git] / libraries / ghci / GHCi / InfoTable.hsc
1 {-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
2
3 -- |
4 -- Run-time info table support.  This module provides support for
5 -- creating and reading info tables /in the running program/.
6 -- We use the RTS data structures directly via hsc2hs.
7 --
8 module GHCi.InfoTable
9   ( mkConInfoTable
10   , peekItbl, StgInfoTable(..)
11   , conInfoPtr
12   ) where
13
14 #if !defined(TABLES_NEXT_TO_CODE)
15 import Data.Maybe (fromJust)
16 #endif
17 import Foreign
18 import Foreign.C
19 import GHC.Ptr
20 import GHC.Exts
21 import System.IO.Unsafe
22
23 mkConInfoTable
24    :: Int     -- ptr words
25    -> Int     -- non-ptr words
26    -> Int     -- constr tag
27    -> [Word8]  -- con desc
28    -> IO (Ptr StgInfoTable)
29       -- resulting info table is allocated with allocateExec(), and
30       -- should be freed with freeExec().
31
32 mkConInfoTable ptr_words nonptr_words tag con_desc =
33   castFunPtrToPtr <$> newExecConItbl itbl con_desc
34   where
35      entry_addr = stg_interp_constr_entry
36      code' = mkJumpToAddr entry_addr
37      itbl  = StgInfoTable {
38                  entry = if ghciTablesNextToCode
39                          then Nothing
40                          else Just entry_addr,
41                  ptrs  = fromIntegral ptr_words,
42                  nptrs = fromIntegral nonptr_words,
43                  tipe  = fromIntegral cONSTR,
44                  srtlen = fromIntegral tag,
45                  code  = if ghciTablesNextToCode
46                          then Just code'
47                          else Nothing
48               }
49
50
51 -- -----------------------------------------------------------------------------
52 -- Building machine code fragments for a constructor's entry code
53
54 type ItblCodes = Either [Word8] [Word32]
55
56 funPtrToInt :: FunPtr a -> Int
57 funPtrToInt (FunPtr a) = I## (addr2Int## a)
58
59 data Arch = ArchSPARC
60           | ArchPPC
61           | ArchX86
62           | ArchX86_64
63           | ArchAlpha
64           | ArchARM
65           | ArchARM64
66           | ArchPPC64
67           | ArchPPC64LE
68           | ArchUnknown
69  deriving Show
70
71 platform :: Arch
72 platform =
73 #if defined(sparc_HOST_ARCH)
74        ArchSPARC
75 #elif defined(powerpc_HOST_ARCH)
76        ArchPPC
77 #elif defined(i386_HOST_ARCH)
78        ArchX86
79 #elif defined(x86_64_HOST_ARCH)
80        ArchX86_64
81 #elif defined(alpha_HOST_ARCH)
82        ArchAlpha
83 #elif defined(arm_HOST_ARCH)
84        ArchARM
85 #elif defined(aarch64_HOST_ARCH)
86        ArchARM64
87 #elif defined(powerpc64_HOST_ARCH)
88        ArchPPC64
89 #elif defined(powerpc64le_HOST_ARCH)
90        ArchPPC64LE
91 #else
92 #    if defined(TABLES_NEXT_TO_CODE)
93 #        error Unimplemented architecture
94 #    else
95        ArchUnknown
96 #    endif
97 #endif
98
99 mkJumpToAddr :: EntryFunPtr -> ItblCodes
100 mkJumpToAddr a = case platform of
101     ArchSPARC ->
102         -- After some consideration, we'll try this, where
103         -- 0x55555555 stands in for the address to jump to.
104         -- According to includes/rts/MachRegs.h, %g3 is very
105         -- likely indeed to be baggable.
106         --
107         --   0000 07155555              sethi   %hi(0x55555555), %g3
108         --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
109         --   0008 81C0C000              jmp     %g3
110         --   000c 01000000              nop
111
112         let w32 = fromIntegral (funPtrToInt a)
113
114             hi22, lo10 :: Word32 -> Word32
115             lo10 x = x .&. 0x3FF
116             hi22 x = (x `shiftR` 10) .&. 0x3FFFF
117
118         in Right [ 0x07000000 .|. (hi22 w32),
119                    0x8610E000 .|. (lo10 w32),
120                    0x81C0C000,
121                    0x01000000 ]
122
123     ArchPPC ->
124         -- We'll use r12, for no particular reason.
125         -- 0xDEADBEEF stands for the address:
126         -- 3D80DEAD lis r12,0xDEAD
127         -- 618CBEEF ori r12,r12,0xBEEF
128         -- 7D8903A6 mtctr r12
129         -- 4E800420 bctr
130
131         let w32 = fromIntegral (funPtrToInt a)
132             hi16 x = (x `shiftR` 16) .&. 0xFFFF
133             lo16 x = x .&. 0xFFFF
134         in Right [ 0x3D800000 .|. hi16 w32,
135                    0x618C0000 .|. lo16 w32,
136                    0x7D8903A6, 0x4E800420 ]
137
138     ArchX86 ->
139         -- Let the address to jump to be 0xWWXXYYZZ.
140         -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
141         -- which is
142         -- B8 ZZ YY XX WW FF E0
143
144         let w32 = fromIntegral (funPtrToInt a) :: Word32
145             insnBytes :: [Word8]
146             insnBytes
147                = [0xB8, byte0 w32, byte1 w32,
148                         byte2 w32, byte3 w32,
149                   0xFF, 0xE0]
150         in
151             Left insnBytes
152
153     ArchX86_64 ->
154         -- Generates:
155         --      jmpq *.L1(%rip)
156         --      .align 8
157         -- .L1:
158         --      .quad <addr>
159         --
160         -- which looks like:
161         --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
162         -- with addr at 10.
163         --
164         -- We need a full 64-bit pointer (we can't assume the info table is
165         -- allocated in low memory).  Assuming the info pointer is aligned to
166         -- an 8-byte boundary, the addr will also be aligned.
167
168         let w64 = fromIntegral (funPtrToInt a) :: Word64
169             insnBytes :: [Word8]
170             insnBytes
171                = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
172                   byte0 w64, byte1 w64, byte2 w64, byte3 w64,
173                   byte4 w64, byte5 w64, byte6 w64, byte7 w64]
174         in
175             Left insnBytes
176
177     ArchAlpha ->
178         let w64 = fromIntegral (funPtrToInt a) :: Word64
179         in Right [ 0xc3800000      -- br   at, .+4
180                  , 0xa79c000c      -- ldq  at, 12(at)
181                  , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
182                  , 0x47ff041f      -- nop
183                  , fromIntegral (w64 .&. 0x0000FFFF)
184                  , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
185
186     ArchARM { } ->
187         -- Generates Arm sequence,
188         --      ldr r1, [pc, #0]
189         --      bx r1
190         --
191         -- which looks like:
192         --     00000000 <.addr-0x8>:
193         --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
194         --     4:       11ff2fe1    bx     r1
195         let w32 = fromIntegral (funPtrToInt a) :: Word32
196         in Left [ 0x00, 0x10, 0x9f, 0xe5
197                 , 0x11, 0xff, 0x2f, 0xe1
198                 , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
199
200     ArchARM64 { } ->
201         -- Generates:
202         --
203         --      ldr     x1, label
204         --      br      x1
205         -- label:
206         --      .quad <addr>
207         --
208         -- which looks like:
209         --     0:       58000041        ldr     x1, <label>
210         --     4:       d61f0020        br      x1
211        let w64 = fromIntegral (funPtrToInt a) :: Word64
212        in Right [ 0x58000041
213                 , 0xd61f0020
214                 , fromIntegral w64
215                 , fromIntegral (w64 `shiftR` 32) ]
216     ArchPPC64 ->
217         -- We use the compiler's register r12 to read the function
218         -- descriptor and the linker's register r11 as a temporary
219         -- register to hold the function entry point.
220         -- In the medium code model the function descriptor
221         -- is located in the first two gigabytes, i.e. the address
222         -- of the function pointer is a non-negative 32 bit number.
223         -- 0x0EADBEEF stands for the address of the function pointer:
224         --    0:   3d 80 0e ad     lis     r12,0x0EAD
225         --    4:   61 8c be ef     ori     r12,r12,0xBEEF
226         --    8:   e9 6c 00 00     ld      r11,0(r12)
227         --    c:   e8 4c 00 08     ld      r2,8(r12)
228         --   10:   7d 69 03 a6     mtctr   r11
229         --   14:   e9 6c 00 10     ld      r11,16(r12)
230         --   18:   4e 80 04 20     bctr
231        let  w32 = fromIntegral (funPtrToInt a)
232             hi16 x = (x `shiftR` 16) .&. 0xFFFF
233             lo16 x = x .&. 0xFFFF
234        in Right [ 0x3D800000 .|. hi16 w32,
235                   0x618C0000 .|. lo16 w32,
236                   0xE96C0000,
237                   0xE84C0008,
238                   0x7D6903A6,
239                   0xE96C0010,
240                   0x4E800420]
241
242     ArchPPC64LE ->
243         -- The ABI requires r12 to point to the function's entry point.
244         -- We use the medium code model where code resides in the first
245         -- two gigabytes, so loading a non-negative32 bit address
246         -- with lis followed by ori is fine.
247         -- 0x0EADBEEF stands for the address:
248         -- 3D800EAD lis r12,0x0EAD
249         -- 618CBEEF ori r12,r12,0xBEEF
250         -- 7D8903A6 mtctr r12
251         -- 4E800420 bctr
252
253         let w32 = fromIntegral (funPtrToInt a)
254             hi16 x = (x `shiftR` 16) .&. 0xFFFF
255             lo16 x = x .&. 0xFFFF
256         in Right [ 0x3D800000 .|. hi16 w32,
257                    0x618C0000 .|. lo16 w32,
258                    0x7D8903A6, 0x4E800420 ]
259
260     -- This code must not be called. You either need to
261     -- add your architecture as a distinct case or
262     -- use non-TABLES_NEXT_TO_CODE mode
263     ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"
264
265 byte0 :: (Integral w) => w -> Word8
266 byte0 w = fromIntegral w
267
268 byte1, byte2, byte3, byte4, byte5, byte6, byte7
269        :: (Integral w, Bits w) => w -> Word8
270 byte1 w = fromIntegral (w `shiftR` 8)
271 byte2 w = fromIntegral (w `shiftR` 16)
272 byte3 w = fromIntegral (w `shiftR` 24)
273 byte4 w = fromIntegral (w `shiftR` 32)
274 byte5 w = fromIntegral (w `shiftR` 40)
275 byte6 w = fromIntegral (w `shiftR` 48)
276 byte7 w = fromIntegral (w `shiftR` 56)
277
278
279 -- -----------------------------------------------------------------------------
280 -- read & write intfo tables
281
282 -- Get definitions for the structs, constants & config etc.
283 #include "Rts.h"
284
285 -- entry point for direct returns for created constr itbls
286 foreign import ccall "&stg_interp_constr_entry"
287     stg_interp_constr_entry :: EntryFunPtr
288
289 -- Ultra-minimalist version specially for constructors
290 #if SIZEOF_VOID_P == 8
291 type HalfWord = Word32
292 #elif SIZEOF_VOID_P == 4
293 type HalfWord = Word16
294 #else
295 #error Uknown SIZEOF_VOID_P
296 #endif
297
298 data StgConInfoTable = StgConInfoTable {
299    conDesc   :: Ptr Word8,
300    infoTable :: StgInfoTable
301 }
302
303 type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
304
305 data StgInfoTable = StgInfoTable {
306    entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
307    ptrs   :: HalfWord,
308    nptrs  :: HalfWord,
309    tipe   :: HalfWord,
310    srtlen :: HalfWord,
311    code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
312   }
313
314 pokeConItbl
315   :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
316   -> IO ()
317 pokeConItbl wr_ptr ex_ptr itbl = do
318   let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)
319 #if defined(TABLES_NEXT_TO_CODE)
320   (#poke StgConInfoTable, con_desc) wr_ptr _con_desc
321 #else
322   (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl)
323 #endif
324   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
325
326 sizeOfEntryCode :: Int
327 sizeOfEntryCode
328   | not ghciTablesNextToCode = 0
329   | otherwise =
330      case mkJumpToAddr undefined of
331        Left  xs -> sizeOf (head xs) * length xs
332        Right xs -> sizeOf (head xs) * length xs
333
334 pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
335 pokeItbl a0 itbl = do
336 #if !defined(TABLES_NEXT_TO_CODE)
337   (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
338 #endif
339   (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
340   (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
341   (#poke StgInfoTable, type) a0 (tipe itbl)
342   (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)
343 #if defined(TABLES_NEXT_TO_CODE)
344   let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code))
345   case code itbl of
346     Nothing -> return ()
347     Just (Left xs) -> pokeArray code_offset xs
348     Just (Right xs) -> pokeArray code_offset xs
349 #endif
350
351 peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
352 peekItbl a0 = do
353 #if defined(TABLES_NEXT_TO_CODE)
354   let entry' = Nothing
355 #else
356   entry' <- Just <$> (#peek StgInfoTable, entry) a0
357 #endif
358   ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0
359   nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0
360   tipe' <- (#peek StgInfoTable, type) a0
361   srtlen' <- (#peek StgInfoTable, srt_bitmap) a0
362   return StgInfoTable
363     { entry  = entry'
364     , ptrs   = ptrs'
365     , nptrs  = nptrs'
366     , tipe   = tipe'
367     , srtlen = srtlen'
368     , code   = Nothing
369     }
370
371 newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
372 newExecConItbl obj con_desc
373    = alloca $ \pcode -> do
374         let lcon_desc = length con_desc + 1{- null terminator -}
375             sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode)
376                -- Note: we need to allocate the conDesc string next to the info
377                -- table, because on a 64-bit platform we reference this string
378                -- with a 32-bit offset relative to the info table, so if we
379                -- allocated the string separately it might be out of range.
380         wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
381         ex_ptr <- peek pcode
382         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
383                                     , infoTable = obj }
384         pokeConItbl wr_ptr ex_ptr cinfo
385         pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
386         _flushExec sz ex_ptr -- Cache flush (if needed)
387         return (castPtrToFunPtr ex_ptr)
388
389 foreign import ccall unsafe "allocateExec"
390   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
391
392 foreign import ccall unsafe "flushExec"
393   _flushExec :: CUInt -> Ptr a -> IO ()
394
395 -- | Convert a pointer to an StgConInfo into an info pointer that can be
396 -- used in the header of a closure.
397 conInfoPtr :: Ptr () -> Ptr ()
398 conInfoPtr ptr
399  | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable)
400  | otherwise            = ptr
401
402 -- -----------------------------------------------------------------------------
403 -- Constants and config
404
405 wORD_SIZE :: Int
406 wORD_SIZE = (#const SIZEOF_HSINT)
407
408 fixedInfoTableSizeB :: Int
409 fixedInfoTableSizeB = 2 * wORD_SIZE
410
411 profInfoTableSizeB :: Int
412 profInfoTableSizeB = (#size StgProfInfo)
413
414 stdInfoTableSizeB :: Int
415 stdInfoTableSizeB
416   = (if ghciTablesNextToCode then 0 else wORD_SIZE)
417   + (if rtsIsProfiled then profInfoTableSizeB else 0)
418   + fixedInfoTableSizeB
419
420 conInfoTableSizeB :: Int
421 conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE
422
423 foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
424
425 rtsIsProfiled :: Bool
426 rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
427
428 cONSTR :: Int   -- Defined in ClosureTypes.h
429 cONSTR = (#const CONSTR)
430
431 ghciTablesNextToCode :: Bool
432 #ifdef TABLES_NEXT_TO_CODE
433 ghciTablesNextToCode = True
434 #else
435 ghciTablesNextToCode = False
436 #endif