Skip to content

GitLab

Commit 75ed401f authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Remove CPP in ByteCodeItbls 

I tried making mkJumpToAddr return [Word32] on all platforms,
but it went wrong on x86 (possibly due to alignment?). Rather than
chasing the bug, I've just used an Either type for now.
parent 978afe6d
Hide whitespace changes
Inline Side-by-side
compiler/ghci/ByteCodeItbls.lhs
View file @ 75ed401f
......@@ -6,20 +6,15 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
#ifndef GHCI_TABLES_NEXT_TO_CODE
{-# OPTIONS_GHC -Wwarn #-}
-- There are lots of warnings when GHCI_TABLES_NEXT_TO_CODE is off.
-- It would be nice to fix this properly, but for now we turn -Werror
-- off.
#endif
module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl
, StgInfoTable(..)
) where
#include "HsVersions.h"
import DynFlags
import Panic
import Platform
import Name ( Name, getName )
import NameEnv
import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
......@@ -28,8 +23,10 @@ import Type ( flattenRepType, repType, typePrimRep )
import StgCmmLayout ( mkVirtHeapOffsets )
import Util
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Maybe
import Foreign
import Foreign.C
......@@ -105,18 +102,18 @@ make_constr_itbls dflags cons
nptrs_really
| ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
| otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
code' = mkJumpToAddr entry_addr
code' = mkJumpToAddr dflags entry_addr
itbl = StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry = entry_addr,
#endif
ptrs = fromIntegral ptrs',
entry = if ghciTablesNextToCode
then Nothing
else Just entry_addr,
ptrs = fromIntegral ptrs',
nptrs = fromIntegral nptrs_really,
tipe = fromIntegral cONSTR,
srtlen = fromIntegral conNo
#ifdef GHCI_TABLES_NEXT_TO_CODE
, code = code'
#endif
srtlen = fromIntegral conNo,
code = if ghciTablesNextToCode
then Just code'
else Nothing
}
qNameCString <- newArray0 0 $ dataConIdentity dcon
let conInfoTbl = StgConInfoTable {
......@@ -133,134 +130,116 @@ make_constr_itbls dflags cons
-- Make code which causes a jump to the given address. This is the
-- only arch-dependent bit of the itbl story. The returned list is
-- itblCodeLength elements (bytes) long.
-- only arch-dependent bit of the itbl story.
-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
#include "nativeGen/NCG.h"
itblCodeLength :: Int
itblCodeLength = length (mkJumpToAddr undefined)
mkJumpToAddr :: Ptr () -> [ItblCode]
type ItblCodes = Either [Word8] [Word32]
ptrToInt :: Ptr a -> Int
ptrToInt (Ptr a#) = I# (addr2Int# a#)
#if sparc_TARGET_ARCH
-- 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
type ItblCode = Word32
mkJumpToAddr a
= let w32 = fromIntegral (ptrToInt a)
hi22, lo10 :: Word32 -> Word32
lo10 x = x .&. 0x3FF
hi22 x = (x `shiftR` 10) .&. 0x3FFFF
in [ 0x07000000 .|. (hi22 w32),
0x8610E000 .|. (lo10 w32),
0x81C0C000,
0x01000000 ]
#elif powerpc_TARGET_ARCH
-- 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
type ItblCode = Word32
mkJumpToAddr a =
let w32 = fromIntegral (ptrToInt a)
hi16 x = (x `shiftR` 16) .&. 0xFFFF
lo16 x = x .&. 0xFFFF
in [
0x3D800000 .|. hi16 w32,
0x618C0000 .|. lo16 w32,
0x7D8903A6, 0x4E800420
]
#elif i386_TARGET_ARCH
-- Let the address to jump to be 0xWWXXYYZZ.
-- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
-- which is
-- B8 ZZ YY XX WW FF E0
type ItblCode = Word8
mkJumpToAddr a
= let w32 = fromIntegral (ptrToInt a) :: Word32
insnBytes :: [Word8]
insnBytes
= [0xB8, byte0 w32, byte1 w32,
byte2 w32, byte3 w32,
0xFF, 0xE0]
in
insnBytes
#elif x86_64_TARGET_ARCH
-- Generates:
-- jmpq *.L1(%rip)
-- .align 8
-- .L1:
-- .quad <addr>
--
-- 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.
type ItblCode = Word8
mkJumpToAddr a
= let w64 = fromIntegral (ptrToInt 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
insnBytes
#elif alpha_TARGET_ARCH
type ItblCode = Word32
mkJumpToAddr a
= [ 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) ]
where w64 = fromIntegral (ptrToInt a) :: Word64
mkJumpToAddr :: DynFlags -> Ptr () -> ItblCodes
mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) 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 (ptrToInt 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 (ptrToInt 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 (ptrToInt 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 (ptrToInt 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 (ptrToInt 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) ]
arch ->
panic ("mkJumpToAddr not defined for " ++ show arch)
#else
type ItblCode = Word32
mkJumpToAddr a
= undefined
#endif
#if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
byte0, byte1, byte2, byte3 :: (Integral w, Bits w) => w -> Word8
byte0 w = fromIntegral w
byte1 w = fromIntegral (w `shiftR` 8)
byte2 w = fromIntegral (w `shiftR` 16)
byte3 w = fromIntegral (w `shiftR` 24)
#endif
#if defined(x86_64_TARGET_ARCH)
byte4, byte5, byte6, byte7 :: (Integral w, Bits w) => w -> Word8
byte4 w = fromIntegral (w `shiftR` 32)
byte5 w = fromIntegral (w `shiftR` 40)
byte6 w = fromIntegral (w `shiftR` 48)
byte7 w = fromIntegral (w `shiftR` 56)
#endif
-- entry point for direct returns for created constr itbls
foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
......@@ -280,95 +259,86 @@ data StgConInfoTable = StgConInfoTable {
infoTable :: StgInfoTable
}
sizeOfConItbl :: StgConInfoTable -> Int
sizeOfConItbl conInfoTable
sizeOfConItbl :: DynFlags -> StgConInfoTable -> Int
sizeOfConItbl dflags conInfoTable
= sum [ fieldSz conDesc conInfoTable
, fieldSz infoTable conInfoTable ]
, sizeOfItbl dflags (infoTable conInfoTable) ]
pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
pokeConItbl dflags wr_ptr ex_ptr itbl
= flip evalStateT (castPtr wr_ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags))
#endif
store (infoTable itbl)
#ifndef GHCI_TABLES_NEXT_TO_CODE
store (conDesc itbl)
#endif
when ghciTablesNextToCode $
store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags))
store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl)
unless ghciTablesNextToCode $ store (conDesc itbl)
data StgInfoTable = StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry :: Ptr (),
#endif
entry :: Maybe (Ptr ()), -- Just <=> not ghciTablesNextToCode
ptrs :: HalfWord,
nptrs :: HalfWord,
tipe :: HalfWord,
srtlen :: HalfWord
#ifdef GHCI_TABLES_NEXT_TO_CODE
, code :: [ItblCode]
#endif
srtlen :: HalfWord,
code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
}
instance Storable StgInfoTable where
sizeOf itbl
sizeOfItbl :: DynFlags -> StgInfoTable -> Int
sizeOfItbl dflags itbl
= sum
[
#ifndef GHCI_TABLES_NEXT_TO_CODE
fieldSz entry itbl,
#endif
if ghciTablesNextToCode then 0 else fieldSz (fromJust . entry) itbl,
fieldSz ptrs itbl,
fieldSz nptrs itbl,
fieldSz tipe itbl,
fieldSz srtlen itbl
#ifdef GHCI_TABLES_NEXT_TO_CODE
,fieldSz (head.code) itbl * itblCodeLength
#endif
fieldSz srtlen itbl,
if ghciTablesNextToCode then case mkJumpToAddr dflags undefined of
Left xs -> sizeOf (head xs) * length xs
Right xs -> sizeOf (head xs) * length xs
else 0
]
alignment _
= SIZEOF_VOID_P
poke a0 itbl
pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO ()
pokeItbl _ a0 itbl
= flip evalStateT (castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
store (entry itbl)
#endif
case entry itbl of
Nothing -> return ()
Just e -> store e
store (ptrs itbl)
store (nptrs itbl)
store (tipe itbl)
store (srtlen itbl)
#ifdef GHCI_TABLES_NEXT_TO_CODE
sequence_ (map store (code itbl))
#endif
case code itbl of
Nothing -> return ()
Just (Left xs) -> mapM_ store xs
Just (Right xs) -> mapM_ store xs
peek a0
peekItbl :: DynFlags -> Ptr StgInfoTable -> IO StgInfoTable
peekItbl dflags a0
= flip evalStateT (castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry' <- load
#endif
entry' <- if ghciTablesNextToCode
then return Nothing
else liftM Just load
ptrs' <- load
nptrs' <- load
tipe' <- load
srtlen' <- load
#ifdef GHCI_TABLES_NEXT_TO_CODE
code' <- sequence (replicate itblCodeLength load)
#endif
return
StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
code' <- if ghciTablesNextToCode
then liftM Just $ case mkJumpToAddr dflags undefined of
Left xs ->
liftM Left $ sequence (replicate (length xs) load)
Right xs ->
liftM Right $ sequence (replicate (length xs) load)
else return Nothing
return
StgInfoTable {
entry = entry',
#endif
ptrs = ptrs',
nptrs = nptrs',
tipe = tipe',
srtlen = srtlen'
#ifdef GHCI_TABLES_NEXT_TO_CODE
,code = code'
#endif
}
fieldSz :: Storable b => (a -> b) -> a -> Int
......@@ -377,28 +347,34 @@ fieldSz sel x = sizeOf (sel x)
type PtrIO = StateT (Ptr Word8) IO
advance :: Storable a => PtrIO (Ptr a)
advance = state adv
advance = advance' sizeOf
advance' :: (a -> Int) -> PtrIO (Ptr a)
advance' fSizeOf = state adv
where adv addr = case castPtr addr of
addrCast ->
(addrCast, addr `plusPtr` sizeOfPointee addrCast)
(addrCast,
addr `plusPtr` sizeOfPointee fSizeOf addrCast)
sizeOfPointee :: (Storable a) => Ptr a -> Int
sizeOfPointee addr = sizeOf (typeHack addr)
sizeOfPointee :: (a -> Int) -> Ptr a -> Int
sizeOfPointee fSizeOf addr = fSizeOf (typeHack addr)
where typeHack = undefined :: Ptr a -> a
store :: Storable a => a -> PtrIO ()
store x = do addr <- advance
lift (poke addr x)
store = store' sizeOf poke
store' :: (a -> Int) -> (Ptr a -> a -> IO ()) -> a -> PtrIO ()
store' fSizeOf fPoke x = do addr <- advance' fSizeOf
lift (fPoke addr x)
load :: Storable a => PtrIO a
load = do addr <- advance
lift (peek addr)
newExecConItbl :: DynFlags -> StgConInfoTable -> IO (FunPtr ())
newExecConItbl dflags obj
= alloca $ \pcode -> do
wr_ptr <- _allocateExec (fromIntegral (sizeOfConItbl obj)) pcode
wr_ptr <- _allocateExec (fromIntegral (sizeOfConItbl dflags obj)) pcode
ex_ptr <- peek pcode
pokeConItbl dflags wr_ptr ex_ptr obj
return (castPtrToFunPtr ex_ptr)
......
compiler/ghci/RtClosureInspect.hs
View file @ 75ed401f
......@@ -33,7 +33,7 @@ module RtClosureInspect(
#include "HsVersions.h"
import DebuggerUtils
import ByteCodeItbls ( StgInfoTable )
import ByteCodeItbls ( StgInfoTable, peekItbl )
import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
import HscTypes
import Linker
......@@ -185,7 +185,7 @@ getClosureData dflags a =
-- into account the extra entry pointer when
-- !ghciTablesNextToCode, so we must adjust here:
Ptr iptr `plusPtr` negate (wORD_SIZE dflags)
itbl <- peek iptr'
itbl <- peekItbl dflags iptr'
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment