From 75ed401fecd487a1daa8f372e616750c5a6832bd Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 9 Apr 2013 13:39:56 +0100 Subject: 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. --- compiler/ghci/ByteCodeItbls.lhs | 344 ++++++++++++++++++-------------------- compiler/ghci/RtClosureInspect.hs | 4 +- 2 files changed, 162 insertions(+), 186 deletions(-) diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 9446d569d5..0d07be5f67 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -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 --- --- 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 + -- + -- which looks like: + -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 + -- 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) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 49e943c0de..d6cbf87fcc 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -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 -- cgit v1.2.1