{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module GHC.HeapView (
GenClosure(..),
Closure,
allClosures,
ClosureType(..),
StgInfoTable(..),
HalfWord,
getClosureData,
getBoxedClosureData,
getClosureRaw,
ppClosure,
HeapTree(..),
buildHeapTree,
ppHeapTree,
HeapGraphEntry(..),
HeapGraphIndex,
HeapGraph(..),
lookupHeapGraph,
heapGraphRoot,
buildHeapGraph,
multiBuildHeapGraph,
addHeapGraph,
annotateHeapGraph,
updateHeapGraph,
ppHeapGraph,
Box(..),
asBox,
areBoxesEqual,
disassembleBCO,
)
where
import GHC.Exts ( Any,
Ptr(..), Addr#, Int(..), Word(..),
ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
unsafeCoerce# )
import GHC.Exts.Heap
import GHC.Exts.Heap.Constants
import GHC.Arr (Array(..))
import Foreign hiding ( void )
import Data.Char
import Data.List
import Data.Maybe ( catMaybes )
import Data.Functor
import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.IntMap as M
import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer.Strict
import Control.Exception.Base (evaluate)
import GHC.Disassembler
#include "ghcautoconf.h"
#if __GLASGOW_HASKELL__ == 806
deriving instance Functor GenClosure
deriving instance Foldable GenClosure
deriving instance Traversable GenClosure
#endif
instance Storable StgInfoTable where
sizeOf :: StgInfoTable -> Int
sizeOf StgInfoTable
itbl
= forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
[
forall b a. Storable b => (a -> b) -> a -> Int
fieldSz StgInfoTable -> HalfWord
ptrs StgInfoTable
itbl,
forall b a. Storable b => (a -> b) -> a -> Int
fieldSz StgInfoTable -> HalfWord
nptrs StgInfoTable
itbl,
forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: HalfWord),
forall b a. Storable b => (a -> b) -> a -> Int
fieldSz StgInfoTable -> HalfWord
srtlen StgInfoTable
itbl
]
alignment :: StgInfoTable -> Int
alignment StgInfoTable
_
= Int
wORD_SIZE
poke :: Ptr StgInfoTable -> StgInfoTable -> IO ()
poke Ptr StgInfoTable
_a0 StgInfoTable
_itbl
= forall a. HasCallStack => [Char] -> a
error [Char]
"Storable StgInfoTable is read-only"
peek :: Ptr StgInfoTable -> IO StgInfoTable
peek Ptr StgInfoTable
a0
= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT) (forall a b. Ptr a -> Ptr b
castPtr Ptr StgInfoTable
a0)
forall a b. (a -> b) -> a -> b
$ do
HalfWord
ptrs' <- forall a. Storable a => PtrIO a
load
HalfWord
nptrs' <- forall a. Storable a => PtrIO a
load
HalfWord
tipe' <- forall a. Storable a => PtrIO a
load
HalfWord
srtlen' <- forall a. Storable a => PtrIO a
load
forall (m :: * -> *) a. Monad m => a -> m a
return
StgInfoTable {
entry :: Maybe EntryFunPtr
entry = forall a. Maybe a
Nothing,
ptrs :: HalfWord
ptrs = HalfWord
ptrs',
nptrs :: HalfWord
nptrs = HalfWord
nptrs',
tipe :: ClosureType
tipe = forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral (HalfWord
tipe'::HalfWord)),
srtlen :: HalfWord
srtlen = HalfWord
srtlen',
code :: Maybe ItblCodes
code = forall a. Maybe a
Nothing
}
fieldSz :: Storable b => (a -> b) -> a -> Int
fieldSz :: forall b a. Storable b => (a -> b) -> a -> Int
fieldSz a -> b
sel a
x = forall a. Storable a => a -> Int
sizeOf (a -> b
sel a
x)
load :: Storable a => PtrIO a
load :: forall a. Storable a => PtrIO a
load = do Ptr a
addr <- forall a. Storable a => PtrIO (Ptr a)
advance
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Storable a => Ptr a -> IO a
peek Ptr a
addr)
type PtrIO = StateT (Ptr Word8) IO
advance :: Storable a => PtrIO (Ptr a)
advance :: forall a. Storable a => PtrIO (Ptr a)
advance = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall {m :: * -> *} {a} {a} {b}.
(Monad m, Storable a) =>
Ptr a -> m (Ptr a, Ptr b)
adv where
adv :: Ptr a -> m (Ptr a, Ptr b)
adv Ptr a
addr = case forall a b. Ptr a -> Ptr b
castPtr Ptr a
addr of { Ptr a
addrCast -> forall (m :: * -> *) a. Monad m => a -> m a
return
(Ptr a
addrCast, Ptr a
addr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => Ptr a -> Int
sizeOfPointee Ptr a
addrCast) }
sizeOfPointee :: (Storable a) => Ptr a -> Int
sizeOfPointee :: forall a. Storable a => Ptr a -> Int
sizeOfPointee Ptr a
addr = forall a. Storable a => a -> Int
sizeOf (forall {a}. Ptr a -> a
typeHack Ptr a
addr)
where typeHack :: Ptr a -> a
typeHack = forall a. HasCallStack => a
undefined :: Ptr a -> a
foreign import prim "stg_unpackClosurezh" unpackClosurezh# :: Any -> (# Addr#, ByteArray#, Array# b #)
getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw :: forall a. a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw a
x =
case forall b. Any -> (# Addr#, ByteArray#, Array# b #)
unpackClosurezh# (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# a
x) of
(# Addr#
iptr, ByteArray#
dat, Array# Any
ptrs #) -> do
let nelems :: Int
nelems = (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
dat)) forall a. Integral a => a -> a -> a
`div` Int
wORD_SIZE
rawWords :: [Word]
rawWords = [Word# -> Word
W# (ByteArray# -> Int# -> Word#
indexWordArray# ByteArray#
dat Int#
i) | I# Int#
i <- [Int
0.. forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems forall a. Num a => a -> a -> a
-Int
1] ]
pelems :: Int
pelems = Int# -> Int
I# (forall a. Array# a -> Int#
sizeofArray# Array# Any
ptrs)
ptrList :: [Box]
ptrList = forall t b. (t -> b) -> Array Int t -> [b]
amap' Any -> Box
Box forall a b. (a -> b) -> a -> b
$ forall i e. i -> i -> Int -> Array# e -> Array i e
Array Int
0 (Int
pelems forall a. Num a => a -> a -> a
- Int
1) Int
pelems Array# Any
ptrs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. a -> IO a
evaluate [Box]
ptrList
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate Int
nelems
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. a -> IO a
evaluate [Word]
rawWords
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Addr# -> Ptr a
Ptr Addr#
iptr, [Word]
rawWords, [Box]
ptrList)
amap' :: (t -> b) -> Array Int t -> [b]
amap' :: forall t b. (t -> b) -> Array Int t -> [b]
amap' t -> b
f (Array Int
i0 Int
i Int
_ Array# t
arr#) = forall a b. (a -> b) -> [a] -> [b]
map Int -> b
g [Int
0 .. Int
i forall a. Num a => a -> a -> a
- Int
i0]
where g :: Int -> b
g (I# Int#
i#) = case forall a. Array# a -> Int# -> (# a #)
indexArray# Array# t
arr# Int#
i# of
(# t
e #) -> t -> b
f t
e
isChar :: GenClosure b -> Maybe Char
isChar :: forall b. GenClosure b -> Maybe Char
isChar (ConstrClosure { name :: forall b. GenClosure b -> [Char]
name = [Char]
"C#", dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs = []}) = forall a. a -> Maybe a
Just (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar GenClosure b
_ = forall a. Maybe a
Nothing
isCons :: GenClosure b -> Maybe (b, b)
isCons :: forall b. GenClosure b -> Maybe (b, b)
isCons (ConstrClosure { name :: forall b. GenClosure b -> [Char]
name = [Char]
":", dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [], ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs = [b
h,b
t]}) = forall a. a -> Maybe a
Just (b
h,b
t)
isCons GenClosure b
_ = forall a. Maybe a
Nothing
isTup :: GenClosure b -> Maybe [b]
isTup :: forall b. GenClosure b -> Maybe [b]
isTup (ConstrClosure { dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [], [b]
[Char]
StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
modl :: forall b. GenClosure b -> [Char]
pkg :: forall b. GenClosure b -> [Char]
name :: [Char]
modl :: [Char]
pkg :: [Char]
ptrArgs :: [b]
info :: StgInfoTable
ptrArgs :: forall b. GenClosure b -> [b]
name :: forall b. GenClosure b -> [Char]
..}) =
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
forall a. [a] -> a
head [Char]
name forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& forall a. [a] -> a
last [Char]
name forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
',') (forall a. [a] -> [a]
tail (forall a. [a] -> [a]
init [Char]
name))
then forall a. a -> Maybe a
Just [b]
ptrArgs else forall a. Maybe a
Nothing
isTup GenClosure b
_ = forall a. Maybe a
Nothing
isNil :: GenClosure b -> Bool
isNil :: forall b. GenClosure b -> Bool
isNil (ConstrClosure { name :: forall b. GenClosure b -> [Char]
name = [Char]
"[]", dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [], ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs = []}) = Bool
True
isNil GenClosure b
_ = Bool
False
ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
ppClosure :: forall b. (Int -> b -> [Char]) -> Int -> GenClosure b -> [Char]
ppClosure Int -> b -> [Char]
showBox Int
prec GenClosure b
c = case GenClosure b
c of
GenClosure b
_ | Just Char
ch <- forall b. GenClosure b -> Maybe Char
isChar GenClosure b
c -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$
[[Char]
"C#", forall a. Show a => a -> [Char]
show Char
ch]
GenClosure b
_ | Just (b
h,b
t) <- forall b. GenClosure b -> Maybe (b, b)
isCons GenClosure b
c -> Bool -> [Char] -> [Char]
addBraces (Int
5 forall a. Ord a => a -> a -> Bool
<= Int
prec) forall a b. (a -> b) -> a -> b
$
Int -> b -> [Char]
showBox Int
5 b
h forall a. [a] -> [a] -> [a]
++ [Char]
" : " forall a. [a] -> [a] -> [a]
++ Int -> b -> [Char]
showBox Int
4 b
t
GenClosure b
_ | Just [b]
vs <- forall b. GenClosure b -> Maybe [b]
isTup GenClosure b
c ->
[Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
0) [b]
vs) forall a. [a] -> [a] -> [a]
++ [Char]
")"
ConstrClosure {[b]
[Char]
[Word]
StgInfoTable
name :: [Char]
modl :: [Char]
pkg :: [Char]
dataArgs :: [Word]
ptrArgs :: [b]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
modl :: forall b. GenClosure b -> [Char]
pkg :: forall b. GenClosure b -> [Char]
ptrArgs :: forall b. GenClosure b -> [b]
dataArgs :: forall b. GenClosure b -> [Word]
name :: forall b. GenClosure b -> [Char]
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$
[Char]
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Word]
dataArgs
ThunkClosure {[b]
[Word]
StgInfoTable
dataArgs :: [Word]
ptrArgs :: [b]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
ptrArgs :: forall b. GenClosure b -> [b]
dataArgs :: forall b. GenClosure b -> [Word]
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$
[Char]
"_thunk" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Word]
dataArgs
SelectorClosure {b
StgInfoTable
selectee :: forall b. GenClosure b -> b
selectee :: b
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"_sel", Int -> b -> [Char]
showBox Int
10 b
selectee]
IndClosure {b
StgInfoTable
indirectee :: forall b. GenClosure b -> b
indirectee :: b
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"_ind", Int -> b -> [Char]
showBox Int
10 b
indirectee]
BlackholeClosure {b
StgInfoTable
indirectee :: b
info :: StgInfoTable
indirectee :: forall b. GenClosure b -> b
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"_bh", Int -> b -> [Char]
showBox Int
10 b
indirectee]
APClosure {b
[b]
HalfWord
StgInfoTable
arity :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
n_args :: forall b. GenClosure b -> HalfWord
payload :: forall b. GenClosure b -> [b]
payload :: [b]
fun :: b
n_args :: HalfWord
arity :: HalfWord
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) forall a b. (a -> b) -> a -> b
$
b
fun forall a. a -> [a] -> [a]
: [b]
payload
PAPClosure {b
[b]
HalfWord
StgInfoTable
payload :: [b]
fun :: b
n_args :: HalfWord
arity :: HalfWord
info :: StgInfoTable
arity :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
n_args :: forall b. GenClosure b -> HalfWord
payload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) forall a b. (a -> b) -> a -> b
$
b
fun forall a. a -> [a] -> [a]
: [b]
payload
APStackClosure {b
[b]
StgInfoTable
payload :: [b]
fun :: b
info :: StgInfoTable
fun :: forall b. GenClosure b -> b
payload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) forall a b. (a -> b) -> a -> b
$
b
fun forall a. a -> [a] -> [a]
: [b]
payload
BCOClosure {b
[Word]
HalfWord
StgInfoTable
bcoptrs :: forall b. GenClosure b -> b
bitmap :: forall b. GenClosure b -> [Word]
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
bitmap :: [Word]
size :: HalfWord
arity :: HalfWord
bcoptrs :: b
literals :: b
instrs :: b
info :: StgInfoTable
arity :: forall b. GenClosure b -> HalfWord
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"_bco", Int -> b -> [Char]
showBox Int
10 b
bcoptrs]
ArrWordsClosure {[Word]
Word
StgInfoTable
arrWords :: forall b. GenClosure b -> [Word]
bytes :: forall b. GenClosure b -> Word
arrWords :: [Word]
bytes :: Word
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"toArray", [Char]
"("forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
arrWords) forall a. [a] -> [a] -> [a]
++ [Char]
" words)", forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [[Char]]
shorten (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Word]
arrWords)) ]
MutArrClosure {[b]
Word
StgInfoTable
mccPayload :: forall b. GenClosure b -> [b]
mccPtrs :: forall b. GenClosure b -> Word
mccSize :: forall b. GenClosure b -> Word
mccPayload :: [b]
mccSize :: Word
mccPtrs :: Word
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"[", forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [[Char]]
shorten (forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
mccPayload)),[Char]
"]"]
MutVarClosure {b
StgInfoTable
var :: forall b. GenClosure b -> b
var :: b
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$
[[Char]
"_mutVar", (Int -> b -> [Char]
showBox Int
10) b
var]
MVarClosure {b
StgInfoTable
queueHead :: forall b. GenClosure b -> b
queueTail :: forall b. GenClosure b -> b
value :: forall b. GenClosure b -> b
value :: b
queueTail :: b
queueHead :: b
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app forall a b. (a -> b) -> a -> b
$
[[Char]
"MVar", (Int -> b -> [Char]
showBox Int
10) b
value]
FunClosure {[b]
[Word]
StgInfoTable
dataArgs :: [Word]
ptrArgs :: [b]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
ptrArgs :: forall b. GenClosure b -> [b]
dataArgs :: forall b. GenClosure b -> [Word]
..} ->
[Char]
"_fun" forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
braceize (forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
0) [b]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Word]
dataArgs)
BlockingQueueClosure {b
StgInfoTable
blackHole :: forall b. GenClosure b -> b
link :: forall b. GenClosure b -> b
owner :: forall b. GenClosure b -> b
queue :: forall b. GenClosure b -> b
queue :: b
owner :: b
blackHole :: b
link :: b
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} ->
[Char]
"_blockingQueue"
IntClosure {Int
PrimType
intVal :: forall b. GenClosure b -> Int
ptipe :: forall b. GenClosure b -> PrimType
intVal :: Int
ptipe :: PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Int", forall a. Show a => a -> [Char]
show Int
intVal]
WordClosure {Word
PrimType
wordVal :: forall b. GenClosure b -> Word
wordVal :: Word
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Word", forall a. Show a => a -> [Char]
show Word
wordVal]
Int64Closure {Int64
PrimType
int64Val :: forall b. GenClosure b -> Int64
int64Val :: Int64
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Int64", forall a. Show a => a -> [Char]
show Int64
int64Val]
Word64Closure {Word64
PrimType
word64Val :: forall b. GenClosure b -> Word64
word64Val :: Word64
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Word64", forall a. Show a => a -> [Char]
show Word64
word64Val]
AddrClosure {Int
PrimType
addrVal :: forall b. GenClosure b -> Int
addrVal :: Int
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Addr", forall a. Show a => a -> [Char]
show Int
addrVal]
FloatClosure {Float
PrimType
floatVal :: forall b. GenClosure b -> Float
floatVal :: Float
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Float", forall a. Show a => a -> [Char]
show Float
floatVal]
DoubleClosure {Double
PrimType
doubleVal :: forall b. GenClosure b -> Double
doubleVal :: Double
ptipe :: PrimType
ptipe :: forall b. GenClosure b -> PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Double", forall a. Show a => a -> [Char]
show Double
doubleVal]
OtherClosure {[b]
[Word]
StgInfoTable
hvalues :: forall b. GenClosure b -> [b]
rawWords :: forall b. GenClosure b -> [Word]
rawWords :: [Word]
hvalues :: [b]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} ->
[Char]
"_other"
UnsupportedClosure {StgInfoTable
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} ->
[Char]
"_unsupported"
#if MIN_VERSION_ghc_heap(8,10,1)
SmallMutArrClosure {[b]
Word
StgInfoTable
mccPayload :: [b]
mccPtrs :: Word
info :: StgInfoTable
mccPayload :: forall b. GenClosure b -> [b]
mccPtrs :: forall b. GenClosure b -> Word
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"[", forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [[Char]]
shorten (forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
mccPayload)),[Char]
"]"]
WeakClosure {b
StgInfoTable
cfinalizers :: forall b. GenClosure b -> b
finalizer :: forall b. GenClosure b -> b
key :: forall b. GenClosure b -> b
link :: b
finalizer :: b
value :: b
key :: b
cfinalizers :: b
info :: StgInfoTable
link :: forall b. GenClosure b -> b
value :: forall b. GenClosure b -> b
info :: forall b. GenClosure b -> StgInfoTable
..} ->
[Char]
"_weak"
#endif
where
app :: [[Char]] -> [Char]
app [[Char]
a] = [Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 forall a. Ord a => a -> a -> Bool
<= Int
prec) (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " [[Char]]
xs)
shorten :: [[Char]] -> [[Char]]
shorten [[Char]]
xs = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
xs forall a. Ord a => a -> a -> Bool
> Int
20 then forall a. Int -> [a] -> [a]
take Int
20 [[Char]]
xs forall a. [a] -> [a] -> [a]
++ [[Char]
"(and more)"] else [[Char]]
xs
data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree
heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
heapTreeClosure (HeapTree Box
_ GenClosure HeapTree
c) = forall a. a -> Maybe a
Just GenClosure HeapTree
c
heapTreeClosure HeapTree
EndOfHeapTree = forall a. Maybe a
Nothing
buildHeapTree :: Int -> Box -> IO HeapTree
buildHeapTree :: Int -> Box -> IO HeapTree
buildHeapTree Int
0 Box
_ = do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HeapTree
EndOfHeapTree
buildHeapTree Int
n Box
b = do
Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
GenClosure HeapTree
c' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (Int -> Box -> IO HeapTree
buildHeapTree (Int
nforall a. Num a => a -> a -> a
-Int
1)) Closure
c
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Box -> GenClosure HeapTree -> HeapTree
HeapTree Box
b GenClosure HeapTree
c'
ppHeapTree :: HeapTree -> String
ppHeapTree :: HeapTree -> [Char]
ppHeapTree = Int -> HeapTree -> [Char]
go Int
0
where
go :: Int -> HeapTree -> [Char]
go Int
_ HeapTree
EndOfHeapTree = [Char]
"..."
go Int
prec t :: HeapTree
t@(HeapTree Box
_ GenClosure HeapTree
c')
| Just [Char]
s <- HeapTree -> Maybe [Char]
isHeapTreeString HeapTree
t = forall a. Show a => a -> [Char]
show [Char]
s
| Just [HeapTree]
l <- HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
t = [Char]
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (forall a b. (a -> b) -> [a] -> [b]
map HeapTree -> [Char]
ppHeapTree [HeapTree]
l) forall a. [a] -> [a] -> [a]
++ [Char]
"]"
| Just [BCI HeapTree]
bc <- forall a b.
(a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO HeapTree -> Maybe (GenClosure HeapTree)
heapTreeClosure GenClosure HeapTree
c'
= [[Char]] -> [Char]
app ([Char]
"_bco" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> HeapTree -> [Char]
go Int
10) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [BCI HeapTree]
bc))
| Bool
otherwise = forall b. (Int -> b -> [Char]) -> Int -> GenClosure b -> [Char]
ppClosure Int -> HeapTree -> [Char]
go Int
prec GenClosure HeapTree
c'
where
app :: [[Char]] -> [Char]
app [[Char]
a] = [Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 forall a. Ord a => a -> a -> Bool
<= Int
prec) (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " [[Char]]
xs)
isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
isHeapTreeList :: HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
tree = do
GenClosure HeapTree
c <- HeapTree -> Maybe (GenClosure HeapTree)
heapTreeClosure HeapTree
tree
if forall b. GenClosure b -> Bool
isNil GenClosure HeapTree
c
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
(HeapTree
h,HeapTree
t) <- forall b. GenClosure b -> Maybe (b, b)
isCons GenClosure HeapTree
c
[HeapTree]
t' <- HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (:) HeapTree
h [HeapTree]
t'
isHeapTreeString :: HeapTree -> Maybe String
isHeapTreeString :: HeapTree -> Maybe [Char]
isHeapTreeString HeapTree
t = do
[HeapTree]
list <- HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
t
if (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HeapTree]
list)
then forall a. Maybe a
Nothing
else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall b. GenClosure b -> Maybe Char
isChar forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< HeapTree -> Maybe (GenClosure HeapTree)
heapTreeClosure) [HeapTree]
list
data HeapGraphEntry a = HeapGraphEntry {
forall a. HeapGraphEntry a -> Box
hgeBox :: Box,
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure :: GenClosure (Maybe HeapGraphIndex),
forall a. HeapGraphEntry a -> Bool
hgeLive :: Bool,
forall a. HeapGraphEntry a -> a
hgeData :: a}
deriving (Int -> HeapGraphEntry a -> [Char] -> [Char]
forall a. Show a => Int -> HeapGraphEntry a -> [Char] -> [Char]
forall a. Show a => [HeapGraphEntry a] -> [Char] -> [Char]
forall a. Show a => HeapGraphEntry a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [HeapGraphEntry a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [HeapGraphEntry a] -> [Char] -> [Char]
show :: HeapGraphEntry a -> [Char]
$cshow :: forall a. Show a => HeapGraphEntry a -> [Char]
showsPrec :: Int -> HeapGraphEntry a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> HeapGraphEntry a -> [Char] -> [Char]
Show, forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
$c<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
fmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
$cfmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
Functor)
type HeapGraphIndex = Int
newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))
deriving (Int -> HeapGraph a -> [Char] -> [Char]
forall a. Show a => Int -> HeapGraph a -> [Char] -> [Char]
forall a. Show a => [HeapGraph a] -> [Char] -> [Char]
forall a. Show a => HeapGraph a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [HeapGraph a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [HeapGraph a] -> [Char] -> [Char]
show :: HeapGraph a -> [Char]
$cshow :: forall a. Show a => HeapGraph a -> [Char]
showsPrec :: Int -> HeapGraph a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> HeapGraph a -> [Char] -> [Char]
Show)
lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
lookupHeapGraph :: forall a. Int -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph Int
i (HeapGraph IntMap (HeapGraphEntry a)
m) = forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (HeapGraphEntry a)
m
heapGraphRoot :: HeapGraphIndex
heapGraphRoot :: Int
heapGraphRoot = Int
0
buildHeapGraph
:: Monoid a
=> Int
-> a
-> Box
-> IO (HeapGraph a)
buildHeapGraph :: forall a. Monoid a => Int -> a -> Box -> IO (HeapGraph a)
buildHeapGraph Int
limit a
rootD Box
initialBox =
forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Monoid a =>
Int -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
multiBuildHeapGraph Int
limit [(a
rootD, Box
initialBox)]
multiBuildHeapGraph
:: Monoid a
=> Int
-> [(a, Box)]
-> IO (HeapGraph a, [(a, HeapGraphIndex)])
multiBuildHeapGraph :: forall a.
Monoid a =>
Int -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
multiBuildHeapGraph Int
limit = forall a.
Monoid a =>
Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit (forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph forall a. IntMap a
M.empty)
addHeapGraph
:: Monoid a
=> Int
-> a
-> Box
-> HeapGraph a
-> IO (HeapGraphIndex, HeapGraph a)
addHeapGraph :: forall a.
Monoid a =>
Int -> a -> Box -> HeapGraph a -> IO (Int, HeapGraph a)
addHeapGraph Int
limit a
d Box
box HeapGraph a
hg = do
(HeapGraph a
hg', [(a
_,Int
i)]) <- forall a.
Monoid a =>
Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit HeapGraph a
hg [(a
d,Box
box)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, HeapGraph a
hg')
annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
annotateHeapGraph :: forall a. Monoid a => a -> Int -> HeapGraph a -> HeapGraph a
annotateHeapGraph a
d Int
i (HeapGraph IntMap (HeapGraphEntry a)
hg) = forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph forall a b. (a -> b) -> a -> b
$ forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
M.update HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go Int
i IntMap (HeapGraphEntry a)
hg
where
go :: HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go HeapGraphEntry a
hge = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HeapGraphEntry a
hge { hgeData :: a
hgeData = forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
hge forall a. Semigroup a => a -> a -> a
<> a
d }
generalBuildHeapGraph
:: Monoid a
=> Int
-> HeapGraph a
-> [(a,Box)]
-> IO (HeapGraph a, [(a, HeapGraphIndex)])
generalBuildHeapGraph :: forall a.
Monoid a =>
Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit HeapGraph a
_ [(a, Box)]
_ | Int
limit forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"buildHeapGraph: limit has to be positive"
generalBuildHeapGraph Int
limit (HeapGraph IntMap (HeapGraphEntry a)
hg) [(a, Box)]
addBoxes = do
let boxList :: [(Box, Int)]
boxList = [ (forall a. HeapGraphEntry a -> Box
hgeBox HeapGraphEntry a
hge, Int
i) | (Int
i, HeapGraphEntry a
hge) <- forall a. IntMap a -> [(Int, a)]
M.toList IntMap (HeapGraphEntry a)
hg ]
indices :: [Int]
indices | forall a. IntMap a -> Bool
M.null IntMap (HeapGraphEntry a)
hg = [Int
0..]
| Bool
otherwise = [Int
1 forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> a
fst (forall a. IntMap a -> (Int, a)
M.findMax IntMap (HeapGraphEntry a)
hg)..]
initialState :: ([(Box, Int)], [Int], [a])
initialState = ([(Box, Int)]
boxList, [Int]
indices, [])
([(a, Int)]
is, IntMap (HeapGraphEntry a)
hg') <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall {c}.
StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
run forall {a}. ([(Box, Int)], [Int], [a])
initialState)
let hg'' :: HeapGraph a
hg'' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Monoid a => a -> Int -> HeapGraph a -> HeapGraph a
annotateHeapGraph)) (forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
hg') [(a, Int)]
is
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapGraph a
hg'', [(a, Int)]
is)
where
run :: StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
run = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell IntMap (HeapGraphEntry a)
hg
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(a, Box)]
addBoxes forall a b. (a -> b) -> a -> b
$ \(a
d, Box
b) -> do
Just Int
i <- forall {t} {c}.
(Eq t, Num t) =>
t
-> Box
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
add Int
limit Box
b
forall (m :: * -> *) a. Monad m => a -> m a
return (a
d, Int
i)
add :: t
-> Box
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
add t
0 Box
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
add t
n Box
b = do
([(Box, Int)]
existing,[Int]
_,c
_) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
Maybe (Box, Int)
mbI <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM (Box -> Box -> IO Bool
areBoxesEqual Box
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Box, Int)]
existing
case Maybe (Box, Int)
mbI of
Just (Box
_,Int
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
i
Maybe (Box, Int)
Nothing -> do
Int
i <- forall {a} {b} {c}.
StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
nextI
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\([(Box, Int)]
x,[Int]
y,c
z) -> ((Box
b,Int
i)forall a. a -> [a] -> [a]
:[(Box, Int)]
x, [Int]
y, c
z))
Closure
c <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Box -> IO Closure
getBoxedClosureData Box
b
GenClosure (Maybe Int)
c' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (t
-> Box
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
add (t
nforall a. Num a => a -> a -> a
-t
1)) Closure
c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. Int -> a -> IntMap a
M.singleton Int
i (forall a.
Box -> GenClosure (Maybe Int) -> Bool -> a -> HeapGraphEntry a
HeapGraphEntry Box
b GenClosure (Maybe Int)
c' Bool
True forall a. Monoid a => a
mempty))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
i
nextI :: StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
nextI = do
b
i <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(a
_,[b]
b,c
_) -> [b]
b))
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\(a
a,[b]
b,c
c) -> (a
a, forall a. [a] -> [a]
tail [b]
b, c
c))
forall (m :: * -> *) a. Monad m => a -> m a
return b
i
updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
updateHeapGraph :: forall a.
Monoid a =>
Int -> HeapGraph a -> IO (HeapGraph a, Int -> Int)
updateHeapGraph Int
limit (HeapGraph IntMap (HeapGraphEntry a)
startHG) = do
(HeapGraph a
hg', IntMap Int
indexMap) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {a}.
(MonadIO m, Monoid a) =>
HeapGraph a
-> (Int, HeapGraphEntry a) -> WriterT (IntMap Int) m (HeapGraph a)
go (forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph forall a. IntMap a
M.empty) (forall a. IntMap a -> [(Int, a)]
M.toList IntMap (HeapGraphEntry a)
startHG)
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapGraph a
hg', forall a. IntMap a -> Int -> a
(M.!) IntMap Int
indexMap)
where
go :: HeapGraph a
-> (Int, HeapGraphEntry a) -> WriterT (IntMap Int) m (HeapGraph a)
go HeapGraph a
hg (Int
i, HeapGraphEntry a
hge) = do
(Int
j, HeapGraph a
hg') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
Int -> a -> Box -> HeapGraph a -> IO (Int, HeapGraph a)
addHeapGraph Int
limit (forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
hge) (forall a. HeapGraphEntry a -> Box
hgeBox HeapGraphEntry a
hge) HeapGraph a
hg
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. Int -> a -> IntMap a
M.singleton Int
i Int
j)
forall (m :: * -> *) a. Monad m => a -> m a
return HeapGraph a
hg'
ppHeapGraph :: HeapGraph a -> String
ppHeapGraph :: forall a. HeapGraph a -> [Char]
ppHeapGraph (HeapGraph IntMap (HeapGraphEntry a)
m) = [Char]
letWrapper forall a. [a] -> [a] -> [a]
++ Int -> Maybe Int -> [Char]
ppRef Int
0 (forall a. a -> Maybe a
Just Int
heapGraphRoot)
where
bindings :: [Int]
bindings = forall a. HeapGraph a -> [Int] -> [Int]
boundMultipleTimes (forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
m) [Int
heapGraphRoot]
letWrapper :: [Char]
letWrapper =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
bindings
then [Char]
""
else [Char]
"let " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n " (forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
ppBinding [Int]
bindings) forall a. [a] -> [a] -> [a]
++ [Char]
"\nin "
bindingLetter :: Int -> Char
bindingLetter Int
i = case forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure (Int -> HeapGraphEntry a
iToE Int
i) of
ThunkClosure {[Maybe Int]
[Word]
StgInfoTable
dataArgs :: [Word]
ptrArgs :: [Maybe Int]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
ptrArgs :: forall b. GenClosure b -> [b]
dataArgs :: forall b. GenClosure b -> [Word]
..} -> Char
't'
SelectorClosure {Maybe Int
StgInfoTable
selectee :: Maybe Int
info :: StgInfoTable
selectee :: forall b. GenClosure b -> b
info :: forall b. GenClosure b -> StgInfoTable
..} -> Char
't'
APClosure {[Maybe Int]
Maybe Int
HalfWord
StgInfoTable
payload :: [Maybe Int]
fun :: Maybe Int
n_args :: HalfWord
arity :: HalfWord
info :: StgInfoTable
arity :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
n_args :: forall b. GenClosure b -> HalfWord
payload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> Char
't'
PAPClosure {[Maybe Int]
Maybe Int
HalfWord
StgInfoTable
payload :: [Maybe Int]
fun :: Maybe Int
n_args :: HalfWord
arity :: HalfWord
info :: StgInfoTable
arity :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
n_args :: forall b. GenClosure b -> HalfWord
payload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> Char
'f'
BCOClosure {[Word]
Maybe Int
HalfWord
StgInfoTable
bitmap :: [Word]
size :: HalfWord
arity :: HalfWord
bcoptrs :: Maybe Int
literals :: Maybe Int
instrs :: Maybe Int
info :: StgInfoTable
bcoptrs :: forall b. GenClosure b -> b
bitmap :: forall b. GenClosure b -> [Word]
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
arity :: forall b. GenClosure b -> HalfWord
info :: forall b. GenClosure b -> StgInfoTable
..} -> Char
't'
FunClosure {[Maybe Int]
[Word]
StgInfoTable
dataArgs :: [Word]
ptrArgs :: [Maybe Int]
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
ptrArgs :: forall b. GenClosure b -> [b]
dataArgs :: forall b. GenClosure b -> [Word]
..} -> Char
'f'
GenClosure (Maybe Int)
_ -> Char
'x'
ppBindingMap :: IntMap [Char]
ppBindingMap = forall a. [(Int, a)] -> IntMap a
M.fromList forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
j (Int
i,Char
c) -> (Int
i, [Char
c] forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
j)) [(Int
1::Int)..]) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd)
[ (Int
i, Int -> Char
bindingLetter Int
i) | Int
i <- [Int]
bindings ]
ppVar :: Int -> [Char]
ppVar Int
i = IntMap [Char]
ppBindingMap forall a. IntMap a -> Int -> a
M.! Int
i
ppBinding :: Int -> [Char]
ppBinding Int
i = Int -> [Char]
ppVar Int
i forall a. [a] -> [a] -> [a]
++ [Char]
" = " forall a. [a] -> [a] -> [a]
++ Int -> HeapGraphEntry a -> [Char]
ppEntry Int
0 (Int -> HeapGraphEntry a
iToE Int
i)
ppEntry :: Int -> HeapGraphEntry a -> [Char]
ppEntry Int
prec HeapGraphEntry a
hge
| Just [Char]
s <- forall a. HeapGraphEntry a -> Maybe [Char]
isString HeapGraphEntry a
hge = forall a. Show a => a -> [Char]
show [Char]
s
| Just [Maybe Int]
l <- forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
hge = [Char]
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> [Char]
ppRef Int
0) [Maybe Int]
l) forall a. [a] -> [a] -> [a]
++ [Char]
"]"
| Just [BCI (Maybe Int)]
bc <- forall a b.
(a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HeapGraphEntry a
iToE)) (forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
= [[Char]] -> [Char]
app ([Char]
"_bco" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> [Char]
ppRef Int
10) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [BCI (Maybe Int)]
bc))
| Bool
otherwise = forall b. (Int -> b -> [Char]) -> Int -> GenClosure b -> [Char]
ppClosure Int -> Maybe Int -> [Char]
ppRef Int
prec (forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
where
app :: [[Char]] -> [Char]
app [[Char]
a] = [Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 forall a. Ord a => a -> a -> Bool
<= Int
prec) (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " [[Char]]
xs)
ppRef :: Int -> Maybe Int -> [Char]
ppRef Int
_ Maybe Int
Nothing = [Char]
"..."
ppRef Int
prec (Just Int
i) | Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
bindings = Int -> [Char]
ppVar Int
i
| Bool
otherwise = Int -> HeapGraphEntry a -> [Char]
ppEntry Int
prec (Int -> HeapGraphEntry a
iToE Int
i)
iToE :: Int -> HeapGraphEntry a
iToE Int
i = IntMap (HeapGraphEntry a)
m forall a. IntMap a -> Int -> a
M.! Int
i
iToUnboundE :: Int -> Maybe (HeapGraphEntry a)
iToUnboundE Int
i = if Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
bindings then forall a. Maybe a
Nothing else forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (HeapGraphEntry a)
m
isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
isList :: forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
hge =
if forall b. GenClosure b -> Bool
isNil (forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
(Maybe Int
h,Maybe Int
t) <- forall b. GenClosure b -> Maybe (b, b)
isCons (forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
Int
ti <- Maybe Int
t
HeapGraphEntry a
e <- Int -> Maybe (HeapGraphEntry a)
iToUnboundE Int
ti
[Maybe Int]
t' <- forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (:) Maybe Int
h [Maybe Int]
t'
isString :: HeapGraphEntry a -> Maybe String
isString :: forall a. HeapGraphEntry a -> Maybe [Char]
isString HeapGraphEntry a
e = do
[Maybe Int]
list <- forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
e
if (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe Int]
list)
then forall a. Maybe a
Nothing
else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall b. GenClosure b -> Maybe Char
isChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> Maybe (HeapGraphEntry a)
iToUnboundE forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. a -> a
id) [Maybe Int]
list
boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
boundMultipleTimes :: forall a. HeapGraph a -> [Int] -> [Int]
boundMultipleTimes (HeapGraph IntMap (HeapGraphEntry a)
m) [Int]
roots = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [[a]]
group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$
[Int]
roots forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. GenClosure b -> [b]
allClosures forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure) (forall a. IntMap a -> [a]
M.elems IntMap (HeapGraphEntry a)
m)
disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO :: forall a b.
(a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO a -> Maybe (GenClosure b)
_ GenClosure a
_ | forall a. a -> a
id Bool
True = forall a. Maybe a
Nothing
disassembleBCO a -> Maybe (GenClosure b)
deref (BCOClosure {a
[Word]
HalfWord
StgInfoTable
bitmap :: [Word]
size :: HalfWord
arity :: HalfWord
bcoptrs :: a
literals :: a
instrs :: a
info :: StgInfoTable
bcoptrs :: forall b. GenClosure b -> b
bitmap :: forall b. GenClosure b -> [Word]
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
arity :: forall b. GenClosure b -> HalfWord
info :: forall b. GenClosure b -> StgInfoTable
..}) = do
GenClosure b
opsC <- a -> Maybe (GenClosure b)
deref a
instrs
GenClosure b
litsC <- a -> Maybe (GenClosure b)
deref a
literals
GenClosure b
ptrsC <- a -> Maybe (GenClosure b)
deref a
bcoptrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall box. [box] -> [Word] -> ByteString -> [BCI box]
disassemble (forall b. GenClosure b -> [b]
mccPayload GenClosure b
ptrsC) (forall b. GenClosure b -> [Word]
arrWords GenClosure b
litsC) (Word -> [Word] -> ByteString
toBytes (forall b. GenClosure b -> Word
bytes GenClosure b
opsC) (forall b. GenClosure b -> [Word]
arrWords GenClosure b
opsC))
disassembleBCO a -> Maybe (GenClosure b)
_ GenClosure a
_ = forall a. Maybe a
Nothing
findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM :: forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
_p [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
findM a -> IO Bool
p (a
x:[a]
xs) = do
Bool
b <- a -> IO Bool
p a
x
if Bool
b then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x) else forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
p [a]
xs
addBraces :: Bool -> String -> String
addBraces :: Bool -> [Char] -> [Char]
addBraces Bool
True [Char]
t = [Char]
"(" forall a. [a] -> [a] -> [a]
++ [Char]
t forall a. [a] -> [a] -> [a]
++ [Char]
")"
addBraces Bool
False [Char]
t = [Char]
t
braceize :: [String] -> String
braceize :: [[Char]] -> [Char]
braceize [] = [Char]
""
braceize [[Char]]
xs = [Char]
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
xs forall a. [a] -> [a] -> [a]
++ [Char]
"}"