import GHC.Arr (Array(..))
-import Foreign hiding ( unsafePerformIO, void )
+import Foreign hiding ( void )
import Numeric ( showHex )
import Data.Char
import Data.List
instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
showsPrec _ (Box a) rs =
- -- unsafePerformIO (print "↓" >> pClosure a) `seq`
+ -- unsafePerformIO (print "↓" >> pClosure a) `seq`
pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
where
ptr = W# (aToWord# a)
tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
addr = ptr - tag
-- want 0s prefixed to pad it out to a fixed length.
- pad_out ls =
+ pad_out ls =
'0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
-- | Boxes can be compared, but this is not pure, as different heap objects can,
{-|
This takes an arbitrary value and puts it into a box. Note that calls like
- > asBox (head list)
+ > asBox (head list)
will put the thunk \"head list\" into the box, /not/ the element at the head
of the list. For that, use careful case expressions:
instance Storable StgInfoTable where
- sizeOf itbl
+ sizeOf itbl
= sum
[
fieldSz ptrs itbl,
fieldSz srtlen itbl
]
- alignment _
+ alignment _
= wORD_SIZE
poke _a0 _itbl
nptrs' <- load
tipe' <- load
srtlen' <- load
- return
- StgInfoTable {
+ return
+ StgInfoTable {
ptrs = ptrs',
nptrs = nptrs',
tipe = toEnum (fromIntegral (tipe'::HalfWord)),
srtlen = srtlen'
}
-fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
+fieldSz :: Storable b => (a -> b) -> a -> Int
fieldSz sel x = sizeOf (sel x)
load :: Storable a => PtrIO a
-}
data GenClosure b =
ConsClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, ptrArgs :: [b]
, dataArgs :: [Word]
, pkg :: String
, name :: String
} |
ThunkClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, ptrArgs :: [b]
, dataArgs :: [Word]
} |
SelectorClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, selectee :: b
} |
IndClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, indirectee :: b
} |
BlackholeClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, indirectee :: b
} |
-- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
-- At least the other direction works via "lookupSymbol
-- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
APClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, arity :: HalfWord
, n_args :: HalfWord
, fun :: b
, payload :: [b]
} |
PAPClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, arity :: HalfWord
, n_args :: HalfWord
, fun :: b
, payload :: [b]
} |
APStackClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, fun :: b
, payload :: [b]
} |
BCOClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, instrs :: b
, literals :: b
, bcoptrs :: b
, bitmap :: Word
} |
ArrWordsClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, bytes :: Word
, arrWords :: [Word]
} |
MutArrClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, mccPtrs :: Word
, mccSize :: Word
, mccPayload :: [b]
-- Card table ignored
} |
MutVarClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, var :: b
} |
MVarClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, queueHead :: b
, queueTail :: b
, value :: b
} |
FunClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, ptrArgs :: [b]
, dataArgs :: [Word]
} |
BlockingQueueClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, link :: b
, blackHole :: b
, owner :: b
, queue :: b
} |
OtherClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
, hvalues :: [b]
, rawWords :: [Word]
} |
UnsupportedClosure {
- info :: StgInfoTable
+ info :: StgInfoTable
}
deriving (Show, Functor, Foldable, Traversable)
type Closure = GenClosure Box
--- | For generic code, this function returns all referenced closures.
+-- | For generic code, this function returns all referenced closures.
allPtrs :: GenClosure b -> [b]
allPtrs (ConsClosure {..}) = ptrArgs
allPtrs (ThunkClosure {..}) = ptrArgs
(# iptr, dat, ptrs #) -> do
let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
- pelems = I# (sizeofArray# ptrs)
+ pelems = I# (sizeofArray# ptrs)
ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
-- This is just for good measure, and seems to be not important.
mapM_ evaluate ptrList
offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
return $ (ptr' `plusPtr` stdInfoTableSizeB)
`plusPtr` (fromIntegral (offsetToString :: Word))
- -- This is code for !ghciTablesNextToCode:
+ -- This is code for !ghciTablesNextToCode:
{-
| otherwise = peek . intPtrToPtr
. (+ fromIntegral
getClosureData x = do
(iptr, wds, ptrs) <- getClosureRaw x
itbl <- peek iptr
- case tipe itbl of
+ case tipe itbl of
t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
(pkg, modl, name) <- dataConInfoPtrToNames iptr
if modl == "ByteCodeInstr" && name == "BreakInfo"
fail "Expected at least 1 ptr argument to AP"
unless (length wds >= 3) $
fail "Expected at least 3 raw words to AP"
- return $ APClosure itbl
+ return $ APClosure itbl
(fromIntegral $ wds !! 2)
(fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
(head ptrs) (tail ptrs)
fail "Expected at least 1 ptr argument to PAP"
unless (length wds >= 3) $
fail "Expected at least 3 raw words to AP"
- return $ PAPClosure itbl
+ return $ PAPClosure itbl
(fromIntegral $ wds !! 2)
(fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
(head ptrs) (tail ptrs)
["_bco"]
ArrWordsClosure {..} -> app
["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]
- MutArrClosure {..} -> app
+ MutArrClosure {..} -> app
["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))]
MutVarClosure {..} -> app $
["_mutVar", (showBox 10) var]
MVarClosure {..} -> app $
["MVar", (showBox 10) value]
- FunClosure {..} ->
+ FunClosure {..} ->
"_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
- BlockingQueueClosure {..} ->
+ BlockingQueueClosure {..} ->
"_blockingQueue"
OtherClosure {..} ->
"_other"
app xs = addBraces (10 <= prec) (intercalate " " xs)
shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
-
+
{- $heapmap
For more global views of the heap, you can use heap maps. These come in
The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
operations expect this to be in the 'Monoid' class: They use 'mempty' to
annotate closures added because the passed values reference them, and they
- use 'mappend' to combine the annotations when two values conincide, e.g.
+ use 'mappend' to combine the annotations when two values conincide, e.g.
during 'updateHeapGraph'.
-}
return $ HeapTree b c'
-- | Pretty-Printing a heap Tree
---
+--
-- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
-- unevaluated expression depending on the command line argument.
--
| Just bc <- disassembleBCO heapTreeClosure c'
= app ("_bco" : map (go 10) (concatMap F.toList bc))
| otherwise = ppClosure go prec c'
- where
+ where
app [a] = a ++ "()"
app xs = addBraces (10 <= prec) (intercalate " " xs)
-- exceeding the recursion bound passed to 'buildHeapGraph'.
--
-- Besides a pointer to the stored value and the closure representation we
--- also keep track of whether the value was still alive at the last update of the
+-- also keep track of whether the value was still alive at the last update of the
-- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
data HeapGraphEntry a = HeapGraphEntry {
hgeBox :: Box,
--
-- Returns the updated 'HeapGraph' and the index of the added value.
addHeapGraph
- :: Monoid a
+ :: Monoid a
=> Int -- ^ Search limit
-> a -- ^ Data to be stored with the added value
-> Box -- ^ Value to add to the graph
where
go hge = Just $ hge { hgeData = hgeData hge <> d }
-generalBuildHeapGraph
+generalBuildHeapGraph
:: Monoid a
=> Int
-> HeapGraph a
let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]
indices | M.null hg = [0..]
| otherwise = [1 + fst (M.findMax hg)..]
-
+
initialState = (boxList, indices, [])
-- It is ok to use the Monoid (IntMap a) instance here, because
-- we will, besides the first time, use 'tell' only to add singletons not
(j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg
tell (M.singleton i j)
return hg'
-
+
-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
--
ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
where
-- All variables occuring more than once
- bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot]
+ bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot]
letWrapper =
if null bindings
ppBindingMap = M.fromList $
concat $
map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
- groupBy ((==) `on` snd) $
+ groupBy ((==) `on` snd) $
sortBy (compare `on` snd)
[ (i, bindingLetter i) | i <- bindings ]
ppRef _ Nothing = "..."
ppRef prec (Just i) | i `elem` bindings = ppVar i
- | otherwise = ppEntry prec (iToE i)
+ | otherwise = ppEntry prec (iToE i)
iToE i = m M.! i
iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
- isList hge =
+ isList hge =
if isNil (hgeClosure hge)
then return []
else do