{-# LINE 1 "libraries/ghci/GHCi/InfoTable.hsc" #-}
{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}

-- Get definitions for the structs, constants & config etc.


-- |
-- Run-time info table support.  This module provides support for
-- creating and reading info tables /in the running program/.
-- We use the RTS data structures directly via hsc2hs.
--
module GHCi.InfoTable
  (
    mkConInfoTable
  ) where

import Prelude hiding (fail) -- See note [Why do we import Prelude here?]

import Foreign
import Foreign.C
import GHC.Ptr
import GHC.Exts
import GHC.Exts.Heap
import Data.ByteString (ByteString)
import Control.Monad.Fail
import qualified Data.ByteString as BS
import GHC.Platform.Host (hostPlatformArch)
import GHC.Platform.ArchOS

-- NOTE: Must return a pointer acceptable for use in the header of a closure.
-- If tables_next_to_code is enabled, then it must point the 'code' field.
-- Otherwise, it should point to the start of the StgInfoTable.
mkConInfoTable
   :: Bool    -- TABLES_NEXT_TO_CODE
   -> Int     -- ptr words
   -> Int     -- non-ptr words
   -> Int     -- constr tag
   -> Int     -- pointer tag
   -> ByteString  -- con desc
   -> IO (Ptr StgInfoTable)
      -- resulting info table is allocated with allocateExecPage(), and
      -- should be freed with freeExecPage().

mkConInfoTable :: Bool
-> Int -> Int -> Int -> Int -> ByteString -> IO (Ptr StgInfoTable)
mkConInfoTable Bool
tables_next_to_code Int
ptr_words Int
nonptr_words Int
tag Int
ptrtag ByteString
con_desc = do
  let entry_addr :: EntryFunPtr
entry_addr = [EntryFunPtr]
interpConstrEntry [EntryFunPtr] -> Int -> EntryFunPtr
forall a. HasCallStack => [a] -> Int -> a
!! Int
ptrtag
  Maybe ItblCodes
code' <- if Bool
tables_next_to_code
    then ItblCodes -> Maybe ItblCodes
forall a. a -> Maybe a
Just (ItblCodes -> Maybe ItblCodes)
-> IO ItblCodes -> IO (Maybe ItblCodes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntryFunPtr -> IO ItblCodes
forall (m :: * -> *). MonadFail m => EntryFunPtr -> m ItblCodes
mkJumpToAddr EntryFunPtr
entry_addr
    else Maybe ItblCodes -> IO (Maybe ItblCodes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ItblCodes
forall a. Maybe a
Nothing
  let
     itbl :: StgInfoTable
itbl  = StgInfoTable {
                 entry :: Maybe EntryFunPtr
entry = if Bool
tables_next_to_code
                         then Maybe EntryFunPtr
forall a. Maybe a
Nothing
                         else EntryFunPtr -> Maybe EntryFunPtr
forall a. a -> Maybe a
Just EntryFunPtr
entry_addr,
                 ptrs :: HalfWord
ptrs  = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ptr_words,
                 nptrs :: HalfWord
nptrs = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nonptr_words,
                 tipe :: ClosureType
tipe  = ClosureType
CONSTR,
                 srtlen :: HalfWord
srtlen = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag,
                 code :: Maybe ItblCodes
code  = Maybe ItblCodes
code'
              }
  FunPtr () -> Ptr StgInfoTable
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr (FunPtr () -> Ptr StgInfoTable)
-> IO (FunPtr ()) -> IO (Ptr StgInfoTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl Bool
tables_next_to_code StgInfoTable
itbl ByteString
con_desc


-- -----------------------------------------------------------------------------
-- Building machine code fragments for a constructor's entry code

funPtrToInt :: FunPtr a -> Int
funPtrToInt :: forall a. FunPtr a -> Int
funPtrToInt (FunPtr Addr#
a) = Int# -> Int
I# (Addr# -> Int#
addr2Int# Addr#
a)

mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
mkJumpToAddr :: forall (m :: * -> *). MonadFail m => EntryFunPtr -> m ItblCodes
mkJumpToAddr EntryFunPtr
a = case Arch
hostPlatformArch of
    Arch
ArchPPC -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- We'll use r12, for no particular reason.
        -- 0xDEADBEEF stands for the address:
        -- 3D80DEAD lis r12,0xDEAD
        -- 618CBEEF ori r12,r12,0xBEEF
        -- 7D8903A6 mtctr r12
        -- 4E800420 bctr

        let w32 :: HalfWord
w32 = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a)
            hi16 :: a -> a
hi16 a
x = (a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
            lo16 :: a -> a
lo16 a
x = a
x a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
        in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0x3D800000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
hi16 HalfWord
w32,
                   HalfWord
0x618C0000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
lo16 HalfWord
w32,
                   HalfWord
0x7D8903A6, HalfWord
0x4E800420 ]

    Arch
ArchX86 -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- Let the address to jump to be 0xWWXXYYZZ.
        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
        -- which is
        -- B8 ZZ YY XX WW FF E0

        let w32 :: HalfWord
w32 = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word32
            insnBytes :: [Word8]
            insnBytes :: [Word8]
insnBytes
               = [Word8
0xB8, HalfWord -> Word8
forall w. Integral w => w -> Word8
byte0 HalfWord
w32, HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte1 HalfWord
w32,
                        HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte2 HalfWord
w32, HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte3 HalfWord
w32,
                  Word8
0xFF, Word8
0xE0]
        in
            [Word8] -> ItblCodes
forall a b. a -> Either a b
Left [Word8]
insnBytes

    Arch
ArchX86_64 -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- Generates:
        --      jmpq *.L1(%rip)
        --      .align 8
        -- .L1:
        --      .quad <addr>
        --
        -- which looks like:
        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
        -- with addr at 10.
        --
        -- We need a full 64-bit pointer (we can't assume the info table is
        -- allocated in low memory).  Assuming the info pointer is aligned to
        -- an 8-byte boundary, the addr will also be aligned.

        let w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word64
            insnBytes :: [Word8]
            insnBytes :: [Word8]
insnBytes
               = [Word8
0xff, Word8
0x25, Word8
0x02, Word8
0x00, Word8
0x00, Word8
0x00, Word8
0x00, Word8
0x00,
                  Word64 -> Word8
forall w. Integral w => w -> Word8
byte0 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte1 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte2 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte3 Word64
w64,
                  Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte4 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte5 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte6 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte7 Word64
w64]
        in
            [Word8] -> ItblCodes
forall a b. a -> Either a b
Left [Word8]
insnBytes

    Arch
ArchAlpha -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        let w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word64
        in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0xc3800000      -- br   at, .+4
                 , HalfWord
0xa79c000c      -- ldq  at, 12(at)
                 , HalfWord
0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
                 , HalfWord
0x47ff041f      -- nop
                 , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0000FFFF)
                 , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0000FFFF) ]

    ArchARM {} -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- Generates Arm sequence,
        --      ldr r1, [pc, #0]
        --      bx r1
        --
        -- which looks like:
        --     00000000 <.addr-0x8>:
        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
        --     4:       11ff2fe1    bx     r1
        let w32 :: HalfWord
w32 = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word32
        in [Word8] -> ItblCodes
forall a b. a -> Either a b
Left [ Word8
0x00, Word8
0x10, Word8
0x9f, Word8
0xe5
                , Word8
0x11, Word8
0xff, Word8
0x2f, Word8
0xe1
                , HalfWord -> Word8
forall w. Integral w => w -> Word8
byte0 HalfWord
w32, HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte1 HalfWord
w32, HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte2 HalfWord
w32, HalfWord -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte3 HalfWord
w32]

    ArchAArch64 {} -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- Generates:
        --
        --      ldr     x1, label
        --      br      x1
        -- label:
        --      .quad <addr>
        --
        -- which looks like:
        --     0:       58000041        ldr     x1, <label>
        --     4:       d61f0020        br      x1
       let w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word64
       in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0x58000041
                , HalfWord
0xd61f0020
                , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64
                , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) ]

    ArchPPC_64 PPC_64ABI
ELF_V1 -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- We use the compiler's register r12 to read the function
        -- descriptor and the linker's register r11 as a temporary
        -- register to hold the function entry point.
        -- In the medium code model the function descriptor
        -- is located in the first two gigabytes, i.e. the address
        -- of the function pointer is a non-negative 32 bit number.
        -- 0x0EADBEEF stands for the address of the function pointer:
        --    0:   3d 80 0e ad     lis     r12,0x0EAD
        --    4:   61 8c be ef     ori     r12,r12,0xBEEF
        --    8:   e9 6c 00 00     ld      r11,0(r12)
        --    c:   e8 4c 00 08     ld      r2,8(r12)
        --   10:   7d 69 03 a6     mtctr   r11
        --   14:   e9 6c 00 10     ld      r11,16(r12)
        --   18:   4e 80 04 20     bctr
       let  w32 :: HalfWord
w32 = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a)
            hi16 :: a -> a
hi16 a
x = (a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
            lo16 :: a -> a
lo16 a
x = a
x a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
       in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0x3D800000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
hi16 HalfWord
w32,
                  HalfWord
0x618C0000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
lo16 HalfWord
w32,
                  HalfWord
0xE96C0000,
                  HalfWord
0xE84C0008,
                  HalfWord
0x7D6903A6,
                  HalfWord
0xE96C0010,
                  HalfWord
0x4E800420]

    ArchPPC_64 PPC_64ABI
ELF_V2 -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- The ABI requires r12 to point to the function's entry point.
        -- We use the medium code model where code resides in the first
        -- two gigabytes, so loading a non-negative32 bit address
        -- with lis followed by ori is fine.
        -- 0x0EADBEEF stands for the address:
        -- 3D800EAD lis r12,0x0EAD
        -- 618CBEEF ori r12,r12,0xBEEF
        -- 7D8903A6 mtctr r12
        -- 4E800420 bctr

        let w32 :: HalfWord
w32 = Int -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a)
            hi16 :: a -> a
hi16 a
x = (a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
            lo16 :: a -> a
lo16 a
x = a
x a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF
        in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0x3D800000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
hi16 HalfWord
w32,
                   HalfWord
0x618C0000 HalfWord -> HalfWord -> HalfWord
forall a. Bits a => a -> a -> a
.|. HalfWord -> HalfWord
forall {a}. (Bits a, Num a) => a -> a
lo16 HalfWord
w32,
                   HalfWord
0x7D8903A6, HalfWord
0x4E800420 ]

    Arch
ArchS390X -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.
        -- The following code loads the address into scratch
        -- register r1 and jumps to it.
        --
        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD
        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH
        --   12:   07 F1                   br      %r1

        let w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word64
        in [Word8] -> ItblCodes
forall a b. a -> Either a b
Left [ Word8
0xC0, Word8
0x1E, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte7 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte6 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte5 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte4 Word64
w64,
                  Word8
0xC0, Word8
0x19, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte3 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte2 Word64
w64, Word64 -> Word8
forall w. (Integral w, Bits w) => w -> Word8
byte1 Word64
w64, Word64 -> Word8
forall w. Integral w => w -> Word8
byte0 Word64
w64,
                  Word8
0x07, Word8
0xF1 ]

    Arch
ArchRISCV64 -> ItblCodes -> m ItblCodes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ItblCodes -> m ItblCodes) -> ItblCodes -> m ItblCodes
forall a b. (a -> b) -> a -> b
$
        let w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EntryFunPtr -> Int
forall a. FunPtr a -> Int
funPtrToInt EntryFunPtr
a) :: Word64
        in [HalfWord] -> ItblCodes
forall a b. b -> Either a b
Right [ HalfWord
0x00000297          -- auipc t0,0
                 , HalfWord
0x01053283          -- ld    t0,16(t0)
                 , HalfWord
0x00028067          -- jr    t0
                 , HalfWord
0x00000013          -- nop
                 , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64
                 , Word64 -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) ]

    Arch
arch ->
      -- The arch isn't supported. You either need to add your architecture as a
      -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.
      String -> m ItblCodes
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ItblCodes) -> String -> m ItblCodes
forall a b. (a -> b) -> a -> b
$ String
"mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ Arch -> String
forall a. Show a => a -> String
show Arch
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

byte0 :: (Integral w) => w -> Word8
byte0 :: forall w. Integral w => w -> Word8
byte0 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral w
w

byte1, byte2, byte3, byte4, byte5, byte6, byte7
       :: (Integral w, Bits w) => w -> Word8
byte1 :: forall w. (Integral w, Bits w) => w -> Word8
byte1 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
byte2 :: forall w. (Integral w, Bits w) => w -> Word8
byte2 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
byte3 :: forall w. (Integral w, Bits w) => w -> Word8
byte3 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
byte4 :: forall w. (Integral w, Bits w) => w -> Word8
byte4 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
byte5 :: forall w. (Integral w, Bits w) => w -> Word8
byte5 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
40)
byte6 :: forall w. (Integral w, Bits w) => w -> Word8
byte6 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
48)
byte7 :: forall w. (Integral w, Bits w) => w -> Word8
byte7 w
w = w -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (w
w w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
56)


-- -----------------------------------------------------------------------------
-- read & write intfo tables

-- entry point for direct returns for created constr itbls
foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr

interpConstrEntry :: [EntryFunPtr]
interpConstrEntry :: [EntryFunPtr]
interpConstrEntry = [ String -> EntryFunPtr
forall a. HasCallStack => String -> a
error String
"pointer tag 0"
                    , EntryFunPtr
stg_interp_constr1_entry
                    , EntryFunPtr
stg_interp_constr2_entry
                    , EntryFunPtr
stg_interp_constr3_entry
                    , EntryFunPtr
stg_interp_constr4_entry
                    , EntryFunPtr
stg_interp_constr5_entry
                    , EntryFunPtr
stg_interp_constr6_entry
                    , EntryFunPtr
stg_interp_constr7_entry ]

data StgConInfoTable = StgConInfoTable {
   StgConInfoTable -> Ptr Word8
conDesc   :: Ptr Word8,
   StgConInfoTable -> StgInfoTable
infoTable :: StgInfoTable
}


pokeConItbl
  :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
  -> IO ()
pokeConItbl :: Bool
-> Ptr StgConInfoTable
-> Ptr StgConInfoTable
-> StgConInfoTable
-> IO ()
pokeConItbl Bool
tables_next_to_code Ptr StgConInfoTable
wr_ptr Ptr StgConInfoTable
_ex_ptr StgConInfoTable
itbl = do
  if Bool
tables_next_to_code
    then do
      -- Write the offset to the con_desc from the end of the standard InfoTable
      -- at the first byte.
      let con_desc_offset :: Int
con_desc_offset = StgConInfoTable -> Ptr Word8
conDesc StgConInfoTable
itbl Ptr Word8 -> Ptr Any -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` (Ptr StgConInfoTable
_ex_ptr Ptr StgConInfoTable -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
conInfoTableSizeB)
      ((\Ptr StgConInfoTable
hsc_ptr -> Ptr StgConInfoTable -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr StgConInfoTable
hsc_ptr Int
0)) Ptr StgConInfoTable
wr_ptr Int
con_desc_offset
{-# LINE 289 "libraries/ghci/GHCi/InfoTable.hsc" #-}
    else do
      -- Write the con_desc address after the end of the info table.
      -- Use itblSize because CPP will not pick up PROFILING when calculating
      -- the offset.
      Ptr StgConInfoTable -> Int -> Ptr Word8 -> IO ()
forall b. Ptr b -> Int -> Ptr Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr StgConInfoTable
wr_ptr Int
itblSize (StgConInfoTable -> Ptr Word8
conDesc StgConInfoTable
itbl)
  Ptr StgInfoTable -> StgInfoTable -> IO ()
pokeItbl (Ptr StgConInfoTable
wr_ptr Ptr StgConInfoTable -> Int -> Ptr StgInfoTable
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` ((Int
8))) (StgConInfoTable -> StgInfoTable
infoTable StgConInfoTable
itbl)
{-# LINE 295 "libraries/ghci/GHCi/InfoTable.hsc" #-}

sizeOfEntryCode :: MonadFail m => Bool -> m Int
sizeOfEntryCode :: forall (m :: * -> *). MonadFail m => Bool -> m Int
sizeOfEntryCode Bool
tables_next_to_code
  | Bool -> Bool
not Bool
tables_next_to_code = Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  | Bool
otherwise = do
     ItblCodes
code' <- EntryFunPtr -> m ItblCodes
forall (m :: * -> *). MonadFail m => EntryFunPtr -> m ItblCodes
mkJumpToAddr EntryFunPtr
forall a. HasCallStack => a
undefined
     Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ case ItblCodes
code' of
       Left  ([Word8]
xs :: [Word8])  -> Word8 -> Int
forall a. Storable a => a -> Int
sizeOf (Word8
forall a. HasCallStack => a
undefined :: Word8)  Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs
       Right ([HalfWord]
xs :: [Word32]) -> HalfWord -> Int
forall a. Storable a => a -> Int
sizeOf (HalfWord
forall a. HasCallStack => a
undefined :: Word32) Int -> Int -> Int
forall a. Num a => a -> a -> a
* [HalfWord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HalfWord]
xs

-- Note: Must return proper pointer for use in a closure
newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl Bool
tables_next_to_code StgInfoTable
obj ByteString
con_desc = do
    Int
sz0 <- Bool -> IO Int
forall (m :: * -> *). MonadFail m => Bool -> m Int
sizeOfEntryCode Bool
tables_next_to_code
    let lcon_desc :: Int
lcon_desc = ByteString -> Int
BS.length ByteString
con_desc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1{- null terminator -}
        -- SCARY
        -- This size represents the number of bytes in an StgConInfoTable.
        sz :: CSize
sz = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Int
conInfoTableSizeB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz0
            -- Note: we need to allocate the conDesc string next to the info
            -- table, because on a 64-bit platform we reference this string
            -- with a 32-bit offset relative to the info table, so if we
            -- allocated the string separately it might be out of range.

    Ptr StgConInfoTable
ex_ptr <- CSize
-> (Ptr StgConInfoTable -> Ptr StgConInfoTable -> IO ())
-> IO (Ptr StgConInfoTable)
forall a. CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)
fillExecBuffer (CSize
sz CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
+ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lcon_desc) ((Ptr StgConInfoTable -> Ptr StgConInfoTable -> IO ())
 -> IO (Ptr StgConInfoTable))
-> (Ptr StgConInfoTable -> Ptr StgConInfoTable -> IO ())
-> IO (Ptr StgConInfoTable)
forall a b. (a -> b) -> a -> b
$ \Ptr StgConInfoTable
wr_ptr Ptr StgConInfoTable
ex_ptr -> do
        let cinfo :: StgConInfoTable
cinfo = StgConInfoTable { conDesc :: Ptr Word8
conDesc = Ptr StgConInfoTable
ex_ptr Ptr StgConInfoTable -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz
                                    , infoTable :: StgInfoTable
infoTable = StgInfoTable
obj }
        Bool
-> Ptr StgConInfoTable
-> Ptr StgConInfoTable
-> StgConInfoTable
-> IO ()
pokeConItbl Bool
tables_next_to_code Ptr StgConInfoTable
wr_ptr Ptr StgConInfoTable
ex_ptr StgConInfoTable
cinfo
        ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
con_desc ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
src, Int
len) ->
            Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr StgConInfoTable -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr StgConInfoTable
wr_ptr Ptr Any -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz) Ptr CChar
src Int
len
        let null_off :: Int
null_off = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
con_desc)
        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr StgConInfoTable -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr StgConInfoTable
wr_ptr Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
null_off) (Word8
0 :: Word8)

    FunPtr () -> IO (FunPtr ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunPtr () -> IO (FunPtr ())) -> FunPtr () -> IO (FunPtr ())
forall a b. (a -> b) -> a -> b
$ if Bool
tables_next_to_code
      then Ptr Any -> FunPtr ()
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr (Ptr Any -> FunPtr ()) -> Ptr Any -> FunPtr ()
forall a b. (a -> b) -> a -> b
$ Ptr StgConInfoTable
ex_ptr Ptr StgConInfoTable -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
conInfoTableSizeB
      else Ptr StgConInfoTable -> FunPtr ()
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr StgConInfoTable
ex_ptr

-- | Allocate a buffer of a given size, use the given action to fill it with
-- data, and mark it as executable. The action is given a writable pointer and
-- the executable pointer. Returns a pointer to the executable code.
fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)


{-# LINE 337 "libraries/ghci/GHCi/InfoTable.hsc" #-}

data ExecPage

foreign import ccall unsafe "allocateExecPage"
  _allocateExecPage :: IO (Ptr ExecPage)

foreign import ccall unsafe "freezeExecPage"
  _freezeExecPage :: Ptr ExecPage -> IO ()

fillExecBuffer :: forall a. CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)
fillExecBuffer CSize
sz Ptr a -> Ptr a -> IO ()
cont
    -- we can only allocate single pages. This assumes a 4k page size which
    -- isn't strictly correct but is a reasonable conservative lower bound.
  | CSize
sz CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
> CSize
4096 = String -> IO (Ptr a)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"withExecBuffer: Too large"
  | Bool
otherwise = do
        Ptr ExecPage
pg <- IO (Ptr ExecPage)
_allocateExecPage
        Ptr a -> Ptr a -> IO ()
cont (Ptr ExecPage -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr ExecPage
pg) (Ptr ExecPage -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr ExecPage
pg)
        Ptr ExecPage -> IO ()
_freezeExecPage Ptr ExecPage
pg
        Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr ExecPage -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr ExecPage
pg)


{-# LINE 376 "libraries/ghci/GHCi/InfoTable.hsc" #-}

-- -----------------------------------------------------------------------------
-- Constants and config

wORD_SIZE :: Int
wORD_SIZE :: Int
wORD_SIZE = (Int
8)
{-# LINE 382 "libraries/ghci/GHCi/InfoTable.hsc" #-}

conInfoTableSizeB :: Int
conInfoTableSizeB :: Int
conInfoTableSizeB = Int
wORD_SIZE Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
itblSize