Commit ec22f7dd authored by patrickdoc's avatar patrickdoc Committed by Ben Gamari

Add HeapView functionality

This pulls parts of Joachim Breitner's ghc-heap-view library inside GHC.
The bits added are the C hooks into the RTS and a basic Haskell wrapper
to these C hooks. The main reason for these to be added to GHC proper
is that the code needs to be kept in sync with the closure types
defined by the RTS. It is expected that the version of HeapView shipped
with GHC will always work with that version of GHC and that extra
functionality can be layered on top with a library like ghc-heap-view
distributed via Hackage.

Test Plan: validate

Reviewers: simonmar, hvr, nomeata, austin, Phyx, bgamari, erikd

Reviewed By: bgamari

Subscribers: carter, patrickdoc, tmcgilchrist, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3055
parent 12deb9a9
......@@ -145,6 +145,7 @@ _darcs/
/libraries/ghc-boot-th/GNUmakefile
/libraries/ghc-boot-th/ghc-boot-th.cabal
/libraries/ghc-boot-th/ghc.mk
/libraries/ghc-heap/ghc-heap.cabal
/libraries/ghci/GNUmakefile
/libraries/ghci/ghci.cabal
/libraries/ghci/ghc.mk
......
......@@ -64,6 +64,7 @@ Library
transformers == 0.5.*,
ghc-boot == @ProjectVersionMunged@,
ghc-boot-th == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
ghci == @ProjectVersionMunged@
if os(windows)
......@@ -643,5 +644,4 @@ Library
Debugger
Linker
RtClosureInspect
DebuggerUtils
GHCi
......@@ -23,7 +23,6 @@ import GhcPrelude
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.InfoTable
import GHCi.BreakArray
import SizedSeq
......@@ -99,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE hsc_env ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
m <- lookupSymbol hsc_env sym_to_find1
......
......@@ -27,7 +27,6 @@ import SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
import GHCi.InfoTable
import Control.DeepSeq
import Foreign
......@@ -36,6 +35,7 @@ import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import GHC.Exts.Heap
import GHC.Stack.CCS
-- -----------------------------------------------------------------------------
......
{-# LANGUAGE CPP #-}
module DebuggerUtils (
dataConInfoPtrToName,
) where
import GhcPrelude
import GHCi.InfoTable
import CmmInfo ( stdInfoTableSizeB )
import DynFlags
import HscTypes
import FastString
import IfaceEnv
import Module
import OccName
import Name
import Outputable
import Util
import Data.Char
import Foreign
import Data.List
#include "HsVersions.h"
-- | Given a data constructor in the heap, find its Name.
-- The info tables for data constructors have a field which records
-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
-- string). The format is:
--
-- > Package:Module.Name
--
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
--
dataConInfoPtrToName :: HscEnv -> Ptr () -> IO Name
dataConInfoPtrToName hsc_env x = do
let dflags = hsc_dflags hsc_env
theString <- do
let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress dflags ptr
peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
pkgFS = mkFastStringByteList pkg
modFS = mkFastStringByteList mod
occFS = mkFastStringByteList occ
occName = mkOccNameFS OccName.dataName occFS
modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
lookupOrigIO hsc_env modName occName
where
{- To find the string in the constructor's info table we need to consider
the layout of info tables relative to the entry code for a closure.
An info table can be next to the entry code for the closure, or it can
be separate. The former (faster) is used in registerised versions of ghc,
and the latter (portable) is for non-registerised versions.
The diagrams below show where the string is to be found relative to
the normal info table of the closure.
1) Code next to table:
--------------
| | <- pointer to the start of the string
--------------
| | <- the (start of the) info table structure
| |
| |
--------------
| entry code |
| .... |
In this case the pointer to the start of the string can be found in
the memory location _one word before_ the first entry in the normal info
table.
2) Code NOT next to table:
--------------
info table structure -> | *------------------> --------------
| | | entry code |
| | | .... |
--------------
ptr to start of str -> | |
--------------
In this case the pointer to the start of the string can be found
in the memory location: info_table_ptr + info_table_size
-}
getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
getConDescAddress dflags ptr
| ghciTablesNextToCode = do
let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)
-- NB. the offset must be read as an Int32 not a Word32, so
-- that the sign is preserved when converting to an Int.
offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32)
return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString
| otherwise =
peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
-- parsing names is a little bit fiddly because we have a string in the form:
-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
-- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
-- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
-- this is not the conventional way of writing Haskell names. We stick with
-- convention, even though it makes the parsing code more troublesome.
-- Warning: this code assumes that the string is well formed.
parse :: [Word8] -> ([Word8], [Word8], [Word8])
parse input
= ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ)
where
dot = fromIntegral (ord '.')
(pkg, rest1) = break (== fromIntegral (ord ':')) input
(mod, occ)
= (concat $ intersperse [dot] $ reverse modWords, occWord)
where
(modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1))
parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
-- We only look for dots if str could start with a module name,
-- i.e. if it starts with an upper case character.
-- Otherwise we might think that "X.:->" is the module name in
-- "X.:->.+", whereas actually "X" is the module name and
-- ":->.+" is a constructor name.
parseModOcc acc str@(c : _)
| isUpper $ chr $ fromIntegral c
= case break (== dot) str of
(top, []) -> (acc, top)
(top, _ : bot) -> parseModOcc (top : acc) bot
parseModOcc acc str = (acc, str)
This diff is collapsed.
......@@ -3024,12 +3024,11 @@ primop NewBCOOp "newBCO#" GenPrimOp
out_of_line = True
primop UnpackClosureOp "unpackClosure#" GenPrimOp
a -> (# Addr#, Array# b, ByteArray# #)
{ {\tt unpackClosure\# closure} copies non-pointers and pointers in the
a -> (# Addr#, ByteArray#, Array# b #)
{ {\tt unpackClosure\# closure} copies the closure and pointers in the
payload of the given closure into two new arrays, and returns a pointer to
the first word of the closure's info table, a pointer array for the
pointers in the payload, and a non-pointer array for the non-pointers in
the payload. }
the first word of the closure's info table, a non-pointer array for the raw
bytes of the closure, and a pointer array for the pointers in the payload. }
with
out_of_line = True
......
......@@ -1323,7 +1323,7 @@ checkMake380() {
checkMake380 make
checkMake380 gmake
AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac])
AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal libraries/ghc-heap/ghc-heap.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac])
AC_OUTPUT
[
if test "$print_make_warning" = "true"; then
......
......@@ -420,7 +420,7 @@ else # CLEANING
# programs such as GHC and ghc-pkg, that we do not assume the stage0
# compiler already has installed (or up-to-date enough).
PACKAGES_STAGE0 = binary text transformers mtl parsec Cabal/Cabal hpc ghc-boot-th ghc-boot template-haskell ghci
PACKAGES_STAGE0 = binary text transformers mtl parsec Cabal/Cabal hpc ghc-boot-th ghc-boot template-haskell ghc-heap ghci
ifeq "$(Windows_Host)" "NO"
PACKAGES_STAGE0 += terminfo
endif
......@@ -459,6 +459,7 @@ PACKAGES_STAGE1 += ghc-boot-th
PACKAGES_STAGE1 += ghc-boot
PACKAGES_STAGE1 += template-haskell
PACKAGES_STAGE1 += ghc-compact
PACKAGES_STAGE1 += ghc-heap
ifeq "$(HADDOCK_DOCS)" "YES"
PACKAGES_STAGE1 += xhtml
......
......@@ -175,6 +175,7 @@ void _assertFail(const char *filename, unsigned int linenum)
#include "rts/storage/FunTypes.h"
#include "rts/storage/InfoTables.h"
#include "rts/storage/Closures.h"
#include "rts/storage/Heap.h"
#include "rts/storage/ClosureTypes.h"
#include "rts/storage/TSO.h"
#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */
......
/* -----------------------------------------------------------------------------
*
* (c) The University of Glasgow 2006-2017
*
* Introspection into GHC's heap representation
*
* ---------------------------------------------------------------------------*/
#pragma once
#include "rts/storage/Closures.h"
StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
, StgClosure *fun, StgClosure **payload, StgWord size);
StgWord heap_view_closureSize(StgClosure *closure);
GNUmakefile
/dist-install/
/dist/
ghc.mk
heapview.cabal
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHC.Exts.Heap
Copyright : (c) 2012 Joachim Breitner
License : BSD3
Maintainer : Joachim Breitner <mail@joachim-breitner.de>
With this module, you can investigate the heap representation of Haskell
values, i.e. to investigate sharing and lazy evaluation.
-}
module GHC.Exts.Heap (
-- * Closure types
Closure
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
, HasHeapRep(getClosureData)
-- * Info Table types
, StgInfoTable(..)
, EntryFunPtr
, HalfWord
, ItblCodes
, itblSize
, peekItbl
, pokeItbl
-- * Closure inspection
, getBoxedClosureData
, allClosures
-- * Boxes
, Box(..)
, asBox
, areBoxesEqual
) where
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Constants
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils
import Control.Monad
import Data.Bits
import GHC.Arr
import GHC.Exts
import GHC.Int
import GHC.Word
class HasHeapRep (a :: TYPE rep) where
getClosureData :: a -> IO Closure
instance HasHeapRep (a :: TYPE 'LiftedRep) where
getClosureData = getClosure
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
getClosureData x = getClosure (unsafeCoerce# x)
instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
getClosureData x = return $
IntClosure { ptipe = PInt, intVal = I# x }
instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
getClosureData x = return $
WordClosure { ptipe = PWord, wordVal = W# x }
instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
getClosureData x = return $
Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
getClosureData x = return $
Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
getClosureData x = return $
AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
getClosureData x = return $
FloatClosure { ptipe = PFloat, floatVal = F# x }
instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
-- | This returns the raw representation of the given argument. The second
-- component of the triple is the raw words of the closure on the heap, and the
-- third component is those words that are actually pointers. Once back in the
-- Haskell world, the raw words that hold pointers may be outdated after a
-- garbage collector run, but the corresponding values in 'Box's will still
-- point to the correct value.
getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw x = do
case unpackClosure# x of
-- This is a hack to cover the bootstrap compiler using the old version of
-- 'unpackClosure'. The new 'unpackClosure' return values are not merely
-- a reordering, so using the old version would not work.
#if MIN_VERSION_ghc_prim(0,5,2)
(# iptr, dat, pointers #) -> do
#else
(# iptr, pointers, dat #) -> do
#endif
let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
end = fromIntegral nelems - 1
rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
pelems = I# (sizeofArray# pointers)
ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
pure (Ptr iptr, rawWds, ptrList)
-- From compiler/ghci/RtClosureInspect.hs
amap' :: (t -> b) -> Array Int t -> [b]
amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
where g (I# i#) = case indexArray# arr# i# of
(# e #) -> f e
-- | This function returns a parsed heap representation of the argument _at
-- this moment_, even if it is unevaluated or an indirection or other exotic
-- stuff. Beware when passing something to this function, the same caveats as
-- for 'asBox' apply.
getClosure :: a -> IO Closure
getClosure x = do
(iptr, wds, pts) <- getClosureRaw x
itbl <- peekItbl iptr
-- The remaining words after the header
let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
-- For data args in a pointers then non-pointers closure
-- This is incorrect in non pointers-first setups
-- not sure if that happens
npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
case tipe itbl of
t | t >= CONSTR && t <= CONSTR_NOCAF -> do
(p, m, n) <- dataConNames iptr
if m == "ByteCodeInstr" && n == "BreakInfo"
then pure $ UnsupportedClosure itbl
else pure $ ConstrClosure itbl pts npts p m n
t | t >= THUNK && t <= THUNK_STATIC -> do
pure $ ThunkClosure itbl pts npts
THUNK_SELECTOR -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
pure $ SelectorClosure itbl (head pts)
t | t >= FUN && t <= FUN_STATIC -> do
pure $ FunClosure itbl pts npts
AP -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to AP"
-- We expect at least the arity, n_args, and fun fields
unless (length rawWds >= 2) $
fail $ "Expected at least 2 raw words to AP"
let splitWord = rawWds !! 0
pure $ APClosure itbl
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(head pts) (tail pts)
PAP -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to PAP"
-- We expect at least the arity, n_args, and fun fields
unless (length rawWds >= 2) $
fail "Expected at least 2 raw words to PAP"
let splitWord = rawWds !! 0
pure $ PAPClosure itbl
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(head pts) (tail pts)
AP_STACK -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to AP_STACK"
pure $ APStackClosure itbl (head pts) (tail pts)
IND -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to IND"
pure $ IndClosure itbl (head pts)
IND_STATIC -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to IND_STATIC"
pure $ IndClosure itbl (head pts)
BLACKHOLE -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to BLACKHOLE"
pure $ BlackholeClosure itbl (head pts)
BCO -> do
unless (length pts >= 3) $
fail $ "Expected at least 3 ptr argument to BCO, found "
++ show (length pts)
unless (length rawWds >= 4) $
fail $ "Expected at least 4 words to BCO, found "
++ show (length rawWds)
let splitWord = rawWds !! 3
pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(drop 4 rawWds)
ARR_WORDS -> do
unless (length rawWds >= 1) $
fail $ "Expected at least 1 words to ARR_WORDS, found "
++ show (length rawWds)
pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)
t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN -> do
unless (length rawWds >= 2) $
fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
++ "found " ++ show (length rawWds)
pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
pure $ MutVarClosure itbl (head pts)
t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
unless (length pts >= 3) $
fail $ "Expected at least 3 ptrs to MVAR, found "
++ show (length pts)
pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
BLOCKING_QUEUE ->
pure $ OtherClosure itbl pts wds
-- pure $ BlockingQueueClosure itbl
-- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
-- pure $ OtherClosure itbl pts wds
--
_ ->
pure $ UnsupportedClosure itbl
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
{-# LANGUAGE CPP #-}
module GHC.Exts.Heap.ClosureTypes
( ClosureType(..)
, closureTypeHeaderSize
) where
{- ---------------------------------------------
-- Enum representing closure types
-- This is a mirror of:
-- includes/rts/storage/ClosureTypes.h
-- ---------------------------------------------}
data ClosureType
= INVALID_OBJECT
| CONSTR
| CONSTR_1_0
| CONSTR_0_1
| CONSTR_2_0
| CONSTR_1_1
| CONSTR_0_2
| CONSTR_NOCAF
| FUN
| FUN_1_0
| FUN_0_1
| FUN_2_0
| FUN_1_1
| FUN_0_2
| FUN_STATIC
| THUNK
| THUNK_1_0
| THUNK_0_1
| THUNK_2_0
| THUNK_1_1
| THUNK_0_2
| THUNK_STATIC
| THUNK_SELECTOR
| BCO
| AP
| PAP
| AP_STACK
| IND
| IND_STATIC
| RET_BCO
| RET_SMALL
| RET_BIG
| RET_FUN
| UPDATE_FRAME
| CATCH_FRAME
| UNDERFLOW_FRAME
| STOP_FRAME
| BLOCKING_QUEUE
| BLACKHOLE
| MVAR_CLEAN
| MVAR_DIRTY
| TVAR
| ARR_WORDS
| MUT_ARR_PTRS_CLEAN
| MUT_ARR_PTRS_DIRTY
| MUT_ARR_PTRS_FROZEN0
| MUT_ARR_PTRS_FROZEN
| MUT_VAR_CLEAN
| MUT_VAR_DIRTY
| WEAK
| PRIM
| MUT_PRIM
| TSO
| STACK
| TREC_CHUNK
| ATOMICALLY_FRAME
| CATCH_RETRY_FRAME
| CATCH_STM_FRAME
| WHITEHOLE
| SMALL_MUT_ARR_PTRS_CLEAN
| SMALL_MUT_ARR_PTRS_DIRTY
| SMALL_MUT_ARR_PTRS_FROZEN0
| SMALL_MUT_ARR_PTRS_FROZEN
| COMPACT_NFDATA
| N_CLOSURE_TYPES
deriving (Enum, Eq, Ord, Show)
-- | Return the size of the closures header in words
closureTypeHeaderSize :: ClosureType -> Int
closureTypeHeaderSize closType =
case closType of
ct | THUNK <= ct && ct <= THUNK_0_2 -> thunkHeader
ct | ct == THUNK_SELECTOR -> thunkHeader
ct | ct == AP -> thunkHeader
ct | ct == AP_STACK -> thunkHeader
_ -> header
where
header = 1 + prof
thunkHeader = 2 + prof
#if defined(PROFILING)
prof = 2
#else
prof = 0
#endif
This diff is collapsed.
{-# LANGUAGE CPP #-}
module GHC.Exts.Heap.Constants
( wORD_SIZE
, tAG_MASK
, wORD_SIZE_IN_BITS
) where
#include "MachDeps.h"
import Data.Bits
wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int
wORD_SIZE = #const SIZEOF_HSWORD
wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS
tAG_MASK = (1 `shift` #const TAG_BITS) - 1
module GHC.Exts.Heap.InfoTable
( module GHC.Exts.Heap.InfoTable.Types
, itblSize
, peekItbl
, pokeItbl
) where
#include "Rts.h"
import GHC.Exts.Heap.InfoTable.Types
#if !defined(TABLES_NEXT_TO_CODE)
import GHC.Exts.Heap.Constants
import Data.Maybe
#endif
import Foreign
-------------------------------------------------------------------------
-- Profiling specific code
--
-- The functions that follow all rely on PROFILING. They are duplicated in
-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This
-- allows hsc2hs to generate values for both profiling and non-profiling builds.
-- | Read an InfoTable from the heap into a haskell type.
-- WARNING: This code assumes it is passed a pointer to a "standard" info
-- table. If tables_next_to_code is enabled, it will look 1 byte before the
-- start for the entry field.
peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
peekItbl a0 = do
#if !defined(TABLES_NEXT_TO_CODE)
let ptr = a0 `plusPtr` (negate wORD_SIZE)
entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
#else
let ptr = a0
entry' = Nothing
#endif
ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
tipe' <- (#peek struct StgInfoTable_, type) ptr
#if __GLASGOW_HASKELL__ > 804
srtlen' <- (#peek struct StgInfoTable_, srt) a0
#else
srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr
#endif
return StgInfoTable
{ entry = entry'
, ptrs = ptrs'
, nptrs = nptrs'
, tipe = toEnum (fromIntegral (tipe' :: HalfWord))
, srtlen = srtlen'
, code = Nothing
}
pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
pokeItbl a0 itbl = do
#if !defined(TABLES_NEXT_TO_CODE)
(#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
#endif
(#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
(#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)