[commit: ghc] master: Fix a couple of bugs in the way info tables are generated for 64-bit platforms (83cf31e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/83cf31e42e87e93eda3e576bc5935509959c2f49/ghc

>---------------------------------------------------------------

commit 83cf31e42e87e93eda3e576bc5935509959c2f49
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Tue Nov 4 15:51:56 2014 +0000

    Fix a couple of bugs in the way info tables are generated for 64-bit platforms
    
    1. The offset was a full word, but it should actually be a 32-bit
    offset on 64-bit platforms.
    2. The con_desc string was allocated separately, which meant that it
    might be out of range for a 32-bit offset.
    
    These bugs meant that +RTS -Di (interpreter debugging) would sometimes
    crash on 64-bit.


>---------------------------------------------------------------

83cf31e42e87e93eda3e576bc5935509959c2f49
 compiler/ghci/ByteCodeItbls.hs | 38 ++++++++++++++++++++++++--------------
 compiler/ghci/DebuggerUtils.hs |  2 +-
 2 files changed, 25 insertions(+), 15 deletions(-)

diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 3288281..d6399ba 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -110,14 +110,10 @@ make_constr_itbls dflags cons
                                    then Just code'
                                    else Nothing
                         }
-           qNameCString <- newArray0 0 $ dataConIdentity dcon
-           let conInfoTbl = StgConInfoTable {
-                                 conDesc = qNameCString,
-                                 infoTable = itbl
-                            }
+
                -- Make a piece of code to jump to "entry_label".
                -- This is the only arch-dependent bit.
-           addrCon <- newExecConItbl dflags conInfoTbl
+           addrCon <- newExecConItbl dflags itbl (dataConIdentity dcon)
                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
@@ -273,12 +269,17 @@ sizeOfConItbl dflags conInfoTable
       = sum [ fieldSz conDesc conInfoTable
             , sizeOfItbl dflags (infoTable conInfoTable) ]
 
-pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable
+            -> StgConInfoTable
             -> IO ()
 pokeConItbl dflags wr_ptr ex_ptr itbl
       = flip evalStateT (castPtr wr_ptr) $ do
-           when ghciTablesNextToCode $
-               store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags))
+           when ghciTablesNextToCode $ do
+               let con_desc = conDesc itbl `minusPtr`
+                      (ex_ptr `plusPtr` conInfoTableSizeB dflags)
+               store (fromIntegral con_desc :: Word32)
+               when (wORD_SIZE dflags == 8) $
+                  store (fromIntegral con_desc :: Word32)
            store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl)
            unless ghciTablesNextToCode $ store (conDesc itbl)
 
@@ -380,13 +381,22 @@ load :: Storable a => PtrIO a
 load = do addr <- advance
           lift (peek addr)
 
-newExecConItbl :: DynFlags -> StgConInfoTable -> IO (FunPtr ())
-newExecConItbl dflags obj
+newExecConItbl :: DynFlags -> StgInfoTable -> [Word8] -> IO (FunPtr ())
+newExecConItbl dflags obj con_desc
    = alloca $ \pcode -> do
-        let sz = fromIntegral (sizeOfConItbl dflags obj)
-        wr_ptr <- _allocateExec sz pcode
+        let lcon_desc = length con_desc + 1{- null terminator -}
+            dummy_cinfo = StgConInfoTable { conDesc = nullPtr, infoTable = obj }
+            sz = fromIntegral (sizeOfConItbl dflags dummy_cinfo)
+               -- 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
-        pokeConItbl dflags wr_ptr ex_ptr obj
+        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
+                                    , infoTable = obj }
+        pokeConItbl dflags 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)
 
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index 9ccb113..cafc375 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -103,7 +103,7 @@ dataConInfoPtrToName x = do
                          4 -> do w <- peek ptr'
                                  return (fromIntegral (w :: Word32))
                          8 -> do w <- peek ptr'
-                                 return (fromIntegral (w :: Word64))
+                                 return (fromIntegral (w :: Word32))
                          w -> panic ("getConDescAddress: Unknown platformWordSize: " ++ show w)
        return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString
     | otherwise =