d9d63146ddeb12896a139bc8a1cb5b823a209fac
[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 import Foreign
15 import Foreign.C
16 import GHC.Ptr
17 import GHC.Exts
18 import System.IO.Unsafe
19
20 mkConInfoTable
21    :: Int     -- ptr words
22    -> Int     -- non-ptr words
23    -> Int     -- constr tag
24    -> [Word8]  -- con desc
25    -> IO (Ptr ())
26       -- resulting info table is allocated with allocateExec(), and
27       -- should be freed with freeExec().
28
29 mkConInfoTable ptr_words nonptr_words tag con_desc =
30   castFunPtrToPtr <$> newExecConItbl itbl con_desc
31   where
32      entry_addr = stg_interp_constr_entry
33      code' = mkJumpToAddr entry_addr
34      itbl  = StgInfoTable {
35                  entry = if ghciTablesNextToCode
36                          then Nothing
37                          else Just entry_addr,
38                  ptrs  = fromIntegral ptr_words,
39                  nptrs = fromIntegral nonptr_words,
40                  tipe  = fromIntegral cONSTR,
41                  srtlen = fromIntegral tag,
42                  code  = if ghciTablesNextToCode
43                          then Just code'
44                          else Nothing
45               }
46
47
48 -- -----------------------------------------------------------------------------
49 -- Building machine code fragments for a constructor's entry code
50
51 type ItblCodes = Either [Word8] [Word32]
52
53 funPtrToInt :: FunPtr a -> Int
54 funPtrToInt (FunPtr a) = I## (addr2Int## a)
55
56 data Arch = ArchSPARC | ArchPPC | ArchX86 | ArchX86_64 | ArchAlpha | ArchARM
57  deriving Show
58
59 platform :: Arch
60 platform =
61 #if defined(sparc_HOST_ARCH)
62        ArchSparc
63 #elif defined(ppc_HOST_ARCH)
64        ArchPPC
65 #elif defined(x86_HOST_ARCH)
66        ArchX86
67 #elif defined(x86_64_HOST_ARCH)
68        ArchX86_64
69 #elif defined(alpha_HOST_ARCH)
70        ArchAlpha
71 #elif defined(arm_HOST_ARCH)
72        ArchARM
73 #endif
74
75 mkJumpToAddr :: EntryFunPtr -> ItblCodes
76 mkJumpToAddr a = case platform of
77     ArchSPARC ->
78         -- After some consideration, we'll try this, where
79         -- 0x55555555 stands in for the address to jump to.
80         -- According to includes/rts/MachRegs.h, %g3 is very
81         -- likely indeed to be baggable.
82         --
83         --   0000 07155555              sethi   %hi(0x55555555), %g3
84         --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
85         --   0008 81C0C000              jmp     %g3
86         --   000c 01000000              nop
87
88         let w32 = fromIntegral (funPtrToInt a)
89
90             hi22, lo10 :: Word32 -> Word32
91             lo10 x = x .&. 0x3FF
92             hi22 x = (x `shiftR` 10) .&. 0x3FFFF
93
94         in Right [ 0x07000000 .|. (hi22 w32),
95                    0x8610E000 .|. (lo10 w32),
96                    0x81C0C000,
97                    0x01000000 ]
98
99     ArchPPC ->
100         -- We'll use r12, for no particular reason.
101         -- 0xDEADBEEF stands for the address:
102         -- 3D80DEAD lis r12,0xDEAD
103         -- 618CBEEF ori r12,r12,0xBEEF
104         -- 7D8903A6 mtctr r12
105         -- 4E800420 bctr
106
107         let w32 = fromIntegral (funPtrToInt a)
108             hi16 x = (x `shiftR` 16) .&. 0xFFFF
109             lo16 x = x .&. 0xFFFF
110         in Right [ 0x3D800000 .|. hi16 w32,
111                    0x618C0000 .|. lo16 w32,
112                    0x7D8903A6, 0x4E800420 ]
113
114     ArchX86 ->
115         -- Let the address to jump to be 0xWWXXYYZZ.
116         -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
117         -- which is
118         -- B8 ZZ YY XX WW FF E0
119
120         let w32 = fromIntegral (funPtrToInt a) :: Word32
121             insnBytes :: [Word8]
122             insnBytes
123                = [0xB8, byte0 w32, byte1 w32,
124                         byte2 w32, byte3 w32,
125                   0xFF, 0xE0]
126         in
127             Left insnBytes
128
129     ArchX86_64 ->
130         -- Generates:
131         --      jmpq *.L1(%rip)
132         --      .align 8
133         -- .L1:
134         --      .quad <addr>
135         --
136         -- which looks like:
137         --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
138         -- with addr at 10.
139         --
140         -- We need a full 64-bit pointer (we can't assume the info table is
141         -- allocated in low memory).  Assuming the info pointer is aligned to
142         -- an 8-byte boundary, the addr will also be aligned.
143
144         let w64 = fromIntegral (funPtrToInt a) :: Word64
145             insnBytes :: [Word8]
146             insnBytes
147                = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
148                   byte0 w64, byte1 w64, byte2 w64, byte3 w64,
149                   byte4 w64, byte5 w64, byte6 w64, byte7 w64]
150         in
151             Left insnBytes
152
153     ArchAlpha ->
154         let w64 = fromIntegral (funPtrToInt a) :: Word64
155         in Right [ 0xc3800000      -- br   at, .+4
156                  , 0xa79c000c      -- ldq  at, 12(at)
157                  , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
158                  , 0x47ff041f      -- nop
159                  , fromIntegral (w64 .&. 0x0000FFFF)
160                  , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
161
162     ArchARM { } ->
163         -- Generates Arm sequence,
164         --      ldr r1, [pc, #0]
165         --      bx r1
166         --
167         -- which looks like:
168         --     00000000 <.addr-0x8>:
169         --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
170         --     4:       11ff2fe1    bx     r1
171         let w32 = fromIntegral (funPtrToInt a) :: Word32
172         in Left [ 0x00, 0x10, 0x9f, 0xe5
173                 , 0x11, 0xff, 0x2f, 0xe1
174                 , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
175
176
177 byte0 :: (Integral w) => w -> Word8
178 byte0 w = fromIntegral w
179
180 byte1, byte2, byte3, byte4, byte5, byte6, byte7
181        :: (Integral w, Bits w) => w -> Word8
182 byte1 w = fromIntegral (w `shiftR` 8)
183 byte2 w = fromIntegral (w `shiftR` 16)
184 byte3 w = fromIntegral (w `shiftR` 24)
185 byte4 w = fromIntegral (w `shiftR` 32)
186 byte5 w = fromIntegral (w `shiftR` 40)
187 byte6 w = fromIntegral (w `shiftR` 48)
188 byte7 w = fromIntegral (w `shiftR` 56)
189
190
191 -- -----------------------------------------------------------------------------
192 -- read & write intfo tables
193
194 -- Get definitions for the structs, constants & config etc.
195 #include "Rts.h"
196
197 -- entry point for direct returns for created constr itbls
198 foreign import ccall "&stg_interp_constr_entry"
199     stg_interp_constr_entry :: EntryFunPtr
200
201 -- Ultra-minimalist version specially for constructors
202 #if SIZEOF_VOID_P == 8
203 type HalfWord = Word32
204 #elif SIZEOF_VOID_P == 4
205 type HalfWord = Word16
206 #else
207 #error Uknown SIZEOF_VOID_P
208 #endif
209
210 data StgConInfoTable = StgConInfoTable {
211    conDesc   :: Ptr Word8,
212    infoTable :: StgInfoTable
213 }
214
215 type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
216
217 data StgInfoTable = StgInfoTable {
218    entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
219    ptrs   :: HalfWord,
220    nptrs  :: HalfWord,
221    tipe   :: HalfWord,
222    srtlen :: HalfWord,
223    code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
224   }
225
226 pokeConItbl
227   :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
228   -> IO ()
229 pokeConItbl wr_ptr ex_ptr itbl = do
230   let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)
231 #if defined(TABLES_NEXT_TO_CODE)
232   (#poke StgConInfoTable, con_desc) wr_ptr _con_desc
233 #else
234   (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl)
235 #endif
236   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
237
238 sizeOfEntryCode :: Int
239 sizeOfEntryCode
240   | not ghciTablesNextToCode = 0
241   | otherwise =
242      case mkJumpToAddr undefined of
243        Left  xs -> sizeOf (head xs) * length xs
244        Right xs -> sizeOf (head xs) * length xs
245
246 pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
247 pokeItbl a0 itbl = do
248 #if !defined(TABLES_NEXT_TO_CODE)
249   (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
250 #endif
251   (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
252   (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
253   (#poke StgInfoTable, type) a0 (tipe itbl)
254   (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)
255 #if defined(TABLES_NEXT_TO_CODE)
256   let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code))
257   case code itbl of
258     Nothing -> return ()
259     Just (Left xs) -> pokeArray code_offset xs
260     Just (Right xs) -> pokeArray code_offset xs
261 #endif
262
263 peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
264 peekItbl a0 = do
265 #if defined(TABLES_NEXT_TO_CODE)
266   let entry' = Nothing
267 #else
268   entry' <- Just <$> (#peek StgInfoTable, entry) a0
269 #endif
270   ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0
271   nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0
272   tipe' <- (#peek StgInfoTable, type) a0
273   srtlen' <- (#peek StgInfoTable, srt_bitmap) a0
274   return StgInfoTable
275     { entry  = entry'
276     , ptrs   = ptrs'
277     , nptrs  = nptrs'
278     , tipe   = tipe'
279     , srtlen = srtlen'
280     , code   = Nothing
281     }
282
283 newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
284 newExecConItbl obj con_desc
285    = alloca $ \pcode -> do
286         let lcon_desc = length con_desc + 1{- null terminator -}
287             sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode)
288                -- Note: we need to allocate the conDesc string next to the info
289                -- table, because on a 64-bit platform we reference this string
290                -- with a 32-bit offset relative to the info table, so if we
291                -- allocated the string separately it might be out of range.
292         wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
293         ex_ptr <- peek pcode
294         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
295                                     , infoTable = obj }
296         pokeConItbl wr_ptr ex_ptr cinfo
297         pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
298         _flushExec sz ex_ptr -- Cache flush (if needed)
299         return (castPtrToFunPtr ex_ptr)
300
301 foreign import ccall unsafe "allocateExec"
302   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
303
304 foreign import ccall unsafe "flushExec"
305   _flushExec :: CUInt -> Ptr a -> IO ()
306
307 -- | Convert a pointer to an StgConInfo into an info pointer that can be
308 -- used in the header of a closure.
309 conInfoPtr :: Ptr () -> Ptr ()
310 conInfoPtr ptr
311  | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable)
312  | otherwise            = ptr
313
314 -- -----------------------------------------------------------------------------
315 -- Constants and config
316
317 wORD_SIZE :: Int
318 wORD_SIZE = (#const SIZEOF_HSINT)
319
320 fixedInfoTableSizeB :: Int
321 fixedInfoTableSizeB = 2 * wORD_SIZE
322
323 profInfoTableSizeB :: Int
324 profInfoTableSizeB = (#size StgProfInfo)
325
326 stdInfoTableSizeB :: Int
327 stdInfoTableSizeB
328   = (if ghciTablesNextToCode then 0 else wORD_SIZE)
329   + (if rtsIsProfiled then profInfoTableSizeB else 0)
330   + fixedInfoTableSizeB
331
332 conInfoTableSizeB :: Int
333 conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE
334
335 foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
336
337 rtsIsProfiled :: Bool
338 rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
339
340 cONSTR :: Int   -- Defined in ClosureTypes.h
341 cONSTR = (#const CONSTR)
342
343 ghciTablesNextToCode :: Bool
344 #ifdef TABLES_NEXT_TO_CODE
345 ghciTablesNextToCode = True
346 #else
347 ghciTablesNextToCode = False
348 #endif