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

-- |
-- 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
  , peekItbl, StgInfoTable(..)
  , conInfoPtr
  ) where


{-# LINE 17 "libraries/ghci/GHCi/InfoTable.hsc" #-}
import Foreign
import Foreign.C
import GHC.Ptr
import GHC.Exts
import System.IO.Unsafe

mkConInfoTable
   :: Int     -- ptr words
   -> Int     -- non-ptr words
   -> Int     -- constr tag
   -> Int     -- pointer tag
   -> [Word8]  -- con desc
   -> IO (Ptr StgInfoTable)
      -- resulting info table is allocated with allocateExec(), and
      -- should be freed with freeExec().

mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
  castFunPtrToPtr <$> newExecConItbl itbl con_desc
  where
     entry_addr = interpConstrEntry !! ptrtag
     code' = mkJumpToAddr entry_addr
     itbl  = StgInfoTable {
                 entry = if ghciTablesNextToCode
                         then Nothing
                         else Just entry_addr,
                 ptrs  = fromIntegral ptr_words,
                 nptrs = fromIntegral nonptr_words,
                 tipe  = fromIntegral cONSTR,
                 srtlen = fromIntegral tag,
                 code  = if ghciTablesNextToCode
                         then Just code'
                         else Nothing
              }


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

type ItblCodes = Either [Word8] [Word32]

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

data Arch = ArchSPARC
          | ArchPPC
          | ArchX86
          | ArchX86_64
          | ArchAlpha
          | ArchARM
          | ArchARM64
          | ArchPPC64
          | ArchPPC64LE
          | ArchUnknown
 deriving Show

platform :: Arch
platform =

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

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

mkJumpToAddr :: EntryFunPtr -> ItblCodes
mkJumpToAddr a = case platform of
    ArchSPARC ->
        -- After some consideration, we'll try this, where
        -- 0x55555555 stands in for the address to jump to.
        -- According to includes/rts/MachRegs.h, %g3 is very
        -- likely indeed to be baggable.
        --
        --   0000 07155555              sethi   %hi(0x55555555), %g3
        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
        --   0008 81C0C000              jmp     %g3
        --   000c 01000000              nop

        let w32 = fromIntegral (funPtrToInt a)

            hi22, lo10 :: Word32 -> Word32
            lo10 x = x .&. 0x3FF
            hi22 x = (x `shiftR` 10) .&. 0x3FFFF

        in Right [ 0x07000000 .|. (hi22 w32),
                   0x8610E000 .|. (lo10 w32),
                   0x81C0C000,
                   0x01000000 ]

    ArchPPC ->
        -- 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 = fromIntegral (funPtrToInt a)
            hi16 x = (x `shiftR` 16) .&. 0xFFFF
            lo16 x = x .&. 0xFFFF
        in Right [ 0x3D800000 .|. hi16 w32,
                   0x618C0000 .|. lo16 w32,
                   0x7D8903A6, 0x4E800420 ]

    ArchX86 ->
        -- 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 = fromIntegral (funPtrToInt a) :: Word32
            insnBytes :: [Word8]
            insnBytes
               = [0xB8, byte0 w32, byte1 w32,
                        byte2 w32, byte3 w32,
                  0xFF, 0xE0]
        in
            Left insnBytes

    ArchX86_64 ->
        -- 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 = fromIntegral (funPtrToInt a) :: Word64
            insnBytes :: [Word8]
            insnBytes
               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,
                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]
        in
            Left insnBytes

    ArchAlpha ->
        let w64 = fromIntegral (funPtrToInt a) :: Word64
        in Right [ 0xc3800000      -- br   at, .+4
                 , 0xa79c000c      -- ldq  at, 12(at)
                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
                 , 0x47ff041f      -- nop
                 , fromIntegral (w64 .&. 0x0000FFFF)
                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]

    ArchARM { } ->
        -- 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 = fromIntegral (funPtrToInt a) :: Word32
        in Left [ 0x00, 0x10, 0x9f, 0xe5
                , 0x11, 0xff, 0x2f, 0xe1
                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]

    ArchARM64 { } ->
        -- Generates:
        --
        --      ldr     x1, label
        --      br      x1
        -- label:
        --      .quad <addr>
        --
        -- which looks like:
        --     0:       58000041        ldr     x1, <label>
        --     4:       d61f0020        br      x1
       let w64 = fromIntegral (funPtrToInt a) :: Word64
       in Right [ 0x58000041
                , 0xd61f0020
                , fromIntegral w64
                , fromIntegral (w64 `shiftR` 32) ]
    ArchPPC64 ->
        -- 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 = fromIntegral (funPtrToInt a)
            hi16 x = (x `shiftR` 16) .&. 0xFFFF
            lo16 x = x .&. 0xFFFF
       in Right [ 0x3D800000 .|. hi16 w32,
                  0x618C0000 .|. lo16 w32,
                  0xE96C0000,
                  0xE84C0008,
                  0x7D6903A6,
                  0xE96C0010,
                  0x4E800420]

    ArchPPC64LE ->
        -- 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 = fromIntegral (funPtrToInt a)
            hi16 x = (x `shiftR` 16) .&. 0xFFFF
            lo16 x = x .&. 0xFFFF
        in Right [ 0x3D800000 .|. hi16 w32,
                   0x618C0000 .|. lo16 w32,
                   0x7D8903A6, 0x4E800420 ]

    -- This code must not be called. You either need to
    -- add your architecture as a distinct case or
    -- use non-TABLES_NEXT_TO_CODE mode
    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"

byte0 :: (Integral w) => w -> Word8
byte0 w = fromIntegral w

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


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

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

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

-- 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 = [ error "pointer tag 0"
                    , stg_interp_constr1_entry
                    , stg_interp_constr2_entry
                    , stg_interp_constr3_entry
                    , stg_interp_constr4_entry
                    , stg_interp_constr5_entry
                    , stg_interp_constr6_entry
                    , stg_interp_constr7_entry ]

-- Ultra-minimalist version specially for constructors

{-# LINE 307 "libraries/ghci/GHCi/InfoTable.hsc" #-}
type HalfWord = Word32

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

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

type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))

data StgInfoTable = StgInfoTable {
   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
   ptrs   :: HalfWord,
   nptrs  :: HalfWord,
   tipe   :: HalfWord,
   srtlen :: HalfWord,
   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
  }

pokeConItbl
  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
  -> IO ()
pokeConItbl wr_ptr ex_ptr itbl = do
  let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)

{-# LINE 336 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) wr_ptr _con_desc
{-# LINE 337 "libraries/ghci/GHCi/InfoTable.hsc" #-}

{-# LINE 340 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  pokeItbl (wr_ptr `plusPtr` ((8))) (infoTable itbl)
{-# LINE 341 "libraries/ghci/GHCi/InfoTable.hsc" #-}

sizeOfEntryCode :: Int
sizeOfEntryCode
  | not ghciTablesNextToCode = 0
  | otherwise =
     case mkJumpToAddr undefined of
       Left  xs -> sizeOf (head xs) * length xs
       Right xs -> sizeOf (head xs) * length xs

pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
pokeItbl a0 itbl = do

{-# LINE 355 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) a0 (ptrs itbl)
{-# LINE 356 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) a0 (nptrs itbl)
{-# LINE 357 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) a0 (tipe itbl)
{-# LINE 358 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) a0 (srtlen itbl)
{-# LINE 359 "libraries/ghci/GHCi/InfoTable.hsc" #-}

{-# LINE 360 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  let code_offset = (a0 `plusPtr` ((16)))
{-# LINE 361 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  case code itbl of
    Nothing -> return ()
    Just (Left xs) -> pokeArray code_offset xs
    Just (Right xs) -> pokeArray code_offset xs

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

peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
peekItbl a0 = do

{-# LINE 370 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  let entry' = Nothing

{-# LINE 374 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  ptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) a0
{-# LINE 375 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  nptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) a0
{-# LINE 376 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  tipe' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) a0
{-# LINE 377 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  srtlen' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) a0
{-# LINE 378 "libraries/ghci/GHCi/InfoTable.hsc" #-}
  return StgInfoTable
    { entry  = entry'
    , ptrs   = ptrs'
    , nptrs  = nptrs'
    , tipe   = tipe'
    , srtlen = srtlen'
    , code   = Nothing
    }

newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
newExecConItbl obj con_desc
   = alloca $ \pcode -> do
        let lcon_desc = length con_desc + 1{- null terminator -}
            sz = fromIntegral (((24)) + sizeOfEntryCode)
{-# LINE 392 "libraries/ghci/GHCi/InfoTable.hsc" #-}
               -- 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.
        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
        ex_ptr <- peek pcode
        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
                                    , infoTable = obj }
        pokeConItbl wr_ptr ex_ptr cinfo
        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
        _flushExec sz ex_ptr -- Cache flush (if needed)
        return (castPtrToFunPtr ex_ptr)

foreign import ccall unsafe "allocateExec"
  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)

foreign import ccall unsafe "flushExec"
  _flushExec :: CUInt -> Ptr a -> IO ()

-- | Convert a pointer to an StgConInfo into an info pointer that can be
-- used in the header of a closure.
conInfoPtr :: Ptr () -> Ptr ()
conInfoPtr ptr
 | ghciTablesNextToCode = ptr `plusPtr` ((24))
{-# LINE 416 "libraries/ghci/GHCi/InfoTable.hsc" #-}
 | otherwise            = ptr

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

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

fixedInfoTableSizeB :: Int
fixedInfoTableSizeB = 2 * wORD_SIZE

profInfoTableSizeB :: Int
profInfoTableSizeB = ((16))
{-# LINE 429 "libraries/ghci/GHCi/InfoTable.hsc" #-}

stdInfoTableSizeB :: Int
stdInfoTableSizeB
  = (if ghciTablesNextToCode then 0 else wORD_SIZE)
  + (if rtsIsProfiled then profInfoTableSizeB else 0)
  + fixedInfoTableSizeB

conInfoTableSizeB :: Int
conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE

foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt

rtsIsProfiled :: Bool
rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0

cONSTR :: Int   -- Defined in ClosureTypes.h
cONSTR = (1)
{-# LINE 446 "libraries/ghci/GHCi/InfoTable.hsc" #-}

ghciTablesNextToCode :: Bool

{-# LINE 449 "libraries/ghci/GHCi/InfoTable.hsc" #-}
ghciTablesNextToCode = True

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