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
......@@ -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)
......
......@@ -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