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