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