diff options
author | Simon Marlow <marlowsd@gmail.com> | 2014-11-04 15:51:56 +0000 |
---|---|---|
committer | Simon Marlow <marlowsd@gmail.com> | 2014-11-05 18:13:50 +0000 |
commit | 83cf31e42e87e93eda3e576bc5935509959c2f49 (patch) | |
tree | f8d00873158f2ecb1b1906930f314ed2dbc5b470 /compiler/ghci | |
parent | 32237f0d9024b2e1ab7cc637a79584bb07a10268 (diff) | |
download | haskell-83cf31e42e87e93eda3e576bc5935509959c2f49.tar.gz |
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.
Diffstat (limited to 'compiler/ghci')
-rw-r--r-- | compiler/ghci/ByteCodeItbls.hs | 38 | ||||
-rw-r--r-- | 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 32882819c1..d6399baf64 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 9ccb113314..cafc3759bf 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 = |