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