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.

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