{-# 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
= [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
[
(StgInfoTable -> HalfWord) -> StgInfoTable -> Int
forall b a. Storable b => (a -> b) -> a -> Int
fieldSz StgInfoTable -> HalfWord
ptrs StgInfoTable
itbl,
(StgInfoTable -> HalfWord) -> StgInfoTable -> Int
forall b a. Storable b => (a -> b) -> a -> Int
fieldSz StgInfoTable -> HalfWord
nptrs StgInfoTable
itbl,
HalfWord -> Int
forall a. Storable a => a -> Int
sizeOf (HalfWord
forall a. HasCallStack => a
undefined :: HalfWord),
(StgInfoTable -> HalfWord) -> StgInfoTable -> Int
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
= [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Storable StgInfoTable is read-only"
peek :: Ptr StgInfoTable -> IO StgInfoTable
peek Ptr StgInfoTable
a0
= (StateT (Ptr Word8) IO StgInfoTable
-> Ptr Word8 -> IO StgInfoTable)
-> Ptr Word8
-> StateT (Ptr Word8) IO StgInfoTable
-> IO StgInfoTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip (StateT (Ptr Word8) IO StgInfoTable -> Ptr Word8 -> IO StgInfoTable
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT) (Ptr StgInfoTable -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr StgInfoTable
a0)
(StateT (Ptr Word8) IO StgInfoTable -> IO StgInfoTable)
-> StateT (Ptr Word8) IO StgInfoTable -> IO StgInfoTable
forall a b. (a -> b) -> a -> b
$ do
HalfWord
ptrs' <- PtrIO HalfWord
forall a. Storable a => PtrIO a
load
HalfWord
nptrs' <- PtrIO HalfWord
forall a. Storable a => PtrIO a
load
HalfWord
tipe' <- PtrIO HalfWord
forall a. Storable a => PtrIO a
load
HalfWord
srtlen' <- PtrIO HalfWord
forall a. Storable a => PtrIO a
load
StgInfoTable -> StateT (Ptr Word8) IO StgInfoTable
forall (m :: * -> *) a. Monad m => a -> m a
return
StgInfoTable :: Maybe EntryFunPtr
-> HalfWord
-> HalfWord
-> ClosureType
-> HalfWord
-> Maybe ItblCodes
-> StgInfoTable
StgInfoTable {
entry :: Maybe EntryFunPtr
entry = Maybe EntryFunPtr
forall a. Maybe a
Nothing,
ptrs :: HalfWord
ptrs = HalfWord
ptrs',
nptrs :: HalfWord
nptrs = HalfWord
nptrs',
tipe :: ClosureType
tipe = Int -> ClosureType
forall a. Enum a => Int -> a
toEnum (HalfWord -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HalfWord
tipe'::HalfWord)),
srtlen :: HalfWord
srtlen = HalfWord
srtlen',
code :: Maybe ItblCodes
code = Maybe ItblCodes
forall a. Maybe a
Nothing
}
fieldSz :: Storable b => (a -> b) -> a -> Int
fieldSz :: (a -> b) -> a -> Int
fieldSz a -> b
sel a
x = b -> Int
forall a. Storable a => a -> Int
sizeOf (a -> b
sel a
x)
load :: Storable a => PtrIO a
load :: PtrIO a
load = do Ptr a
addr <- PtrIO (Ptr a)
forall a. Storable a => PtrIO (Ptr a)
advance
IO a -> PtrIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Ptr a -> IO a
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 :: PtrIO (Ptr a)
advance = (Ptr Word8 -> IO (Ptr a, Ptr Word8)) -> PtrIO (Ptr a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT Ptr Word8 -> IO (Ptr a, Ptr Word8)
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 Ptr a -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr a
addr of { Ptr a
addrCast -> (Ptr a, Ptr b) -> m (Ptr a, Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return
(Ptr a
addrCast, Ptr a
addr Ptr a -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Ptr a -> Int
forall a. Storable a => Ptr a -> Int
sizeOfPointee Ptr a
addrCast) }
sizeOfPointee :: (Storable a) => Ptr a -> Int
sizeOfPointee :: Ptr a -> Int
sizeOfPointee Ptr a
addr = a -> Int
forall a. Storable a => a -> Int
sizeOf (Ptr a -> a
forall a. Ptr a -> a
typeHack Ptr a
addr)
where typeHack :: Ptr a -> a
typeHack = forall a. Ptr a -> a
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 :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw a
x =
case Any -> (# Addr#, ByteArray#, Array# Any #)
forall b. Any -> (# Addr#, ByteArray#, Array# b #)
unpackClosurezh# (a -> Any
unsafeCoerce# a
x) of
(# Addr#
iptr, ByteArray#
dat, Array# Any
ptrs #) -> do
let nelems :: Int
nelems = (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
dat)) Int -> Int -> Int
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.. Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
pelems :: Int
pelems = Int# -> Int
I# (Array# Any -> Int#
forall a. Array# a -> Int#
sizeofArray# Array# Any
ptrs)
ptrList :: [Box]
ptrList = (Any -> Box) -> Array Int Any -> [Box]
forall t b. (t -> b) -> Array Int t -> [b]
amap' Any -> Box
Box (Array Int Any -> [Box]) -> Array Int Any -> [Box]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Array# Any -> Array Int Any
forall i e. i -> i -> Int -> Array# e -> Array i e
Array Int
0 (Int
pelems Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
pelems Array# Any
ptrs
(Box -> IO Box) -> [Box] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Box -> IO Box
forall a. a -> IO a
evaluate [Box]
ptrList
IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
evaluate Int
nelems
(Word -> IO Word) -> [Word] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word -> IO Word
forall a. a -> IO a
evaluate [Word]
rawWords
(Ptr StgInfoTable, [Word], [Box])
-> IO (Ptr StgInfoTable, [Word], [Box])
forall (m :: * -> *) a. Monad m => a -> m a
return (Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr Addr#
iptr, [Word]
rawWords, [Box]
ptrList)
amap' :: (t -> b) -> Array Int t -> [b]
amap' :: (t -> b) -> Array Int t -> [b]
amap' t -> b
f (Array Int
i0 Int
i Int
_ Array# t
arr#) = (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Int -> b
g [Int
0 .. Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i0]
where g :: Int -> b
g (I# Int#
i#) = case Array# t -> Int# -> (# t #)
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 :: 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 = []}) = Char -> Maybe Char
forall a. a -> Maybe a
Just (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar GenClosure b
_ = Maybe Char
forall a. Maybe a
Nothing
isCons :: GenClosure b -> Maybe (b, b)
isCons :: 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]}) = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
h,b
t)
isCons GenClosure b
_ = Maybe (b, b)
forall a. Maybe a
Nothing
isTup :: GenClosure b -> Maybe [b]
isTup :: GenClosure b -> Maybe [b]
isTup (ConstrClosure { dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [], [b]
[Char]
StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
pkg :: forall b. GenClosure b -> [Char]
modl :: 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 [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
[Char] -> Char
forall a. [a] -> a
head [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
last [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
(Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') ([Char] -> [Char]
forall a. [a] -> [a]
tail ([Char] -> [Char]
forall a. [a] -> [a]
init [Char]
name))
then [b] -> Maybe [b]
forall a. a -> Maybe a
Just [b]
ptrArgs else Maybe [b]
forall a. Maybe a
Nothing
isTup GenClosure b
_ = Maybe [b]
forall a. Maybe a
Nothing
isNil :: GenClosure b -> Bool
isNil :: 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 :: (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 <- GenClosure b -> Maybe Char
forall b. GenClosure b -> Maybe Char
isChar GenClosure b
c -> [[Char]] -> [Char]
app ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
[[Char]
"C#", Char -> [Char]
forall a. Show a => a -> [Char]
show Char
ch]
GenClosure b
_ | Just (b
h,b
t) <- GenClosure b -> Maybe (b, b)
forall b. GenClosure b -> Maybe (b, b)
isCons GenClosure b
c -> Bool -> [Char] -> [Char]
addBraces (Int
5 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
Int -> b -> [Char]
showBox Int
5 b
h [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> b -> [Char]
showBox Int
4 b
t
GenClosure b
_ | Just [b]
vs <- GenClosure b -> Maybe [b]
forall b. GenClosure b -> Maybe [b]
isTup GenClosure b
c ->
[Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ((b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
0) [b]
vs) [Char] -> [Char] -> [Char]
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
pkg :: forall b. GenClosure b -> [Char]
modl :: 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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
[Char]
name [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
ptrArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Word -> [Char]) -> [Word] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word -> [Char]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
[Char]
"_thunk" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) [b]
ptrArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Word -> [Char]) -> [Word] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word -> [Char]
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
n_args :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) ([b] -> [[Char]]) -> [b] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
b
fun b -> [b] -> [b]
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
n_args :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
payload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) ([b] -> [[Char]]) -> [b] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
b
fun b -> [b] -> [b]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
10) ([b] -> [[Char]]) -> [b] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
b
fun b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
payload
BCOClosure {b
[Word]
HalfWord
StgInfoTable
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
bcoptrs :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
bitmap :: forall b. GenClosure b -> [Word]
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
bytes :: forall b. GenClosure b -> Word
arrWords :: forall b. GenClosure b -> [Word]
arrWords :: [Word]
bytes :: Word
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"toArray", [Char]
"("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
arrWords) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" words)", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [[Char]]
shorten ((Word -> [Char]) -> [Word] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word -> [Char]
forall a. Show a => a -> [Char]
show [Word]
arrWords)) ]
MutArrClosure {[b]
Word
StgInfoTable
mccPtrs :: forall b. GenClosure b -> Word
mccSize :: forall b. GenClosure b -> Word
mccPayload :: forall b. GenClosure b -> [b]
mccPayload :: [b]
mccSize :: Word
mccPtrs :: Word
info :: StgInfoTable
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"[", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [[Char]]
shorten ((b -> [Char]) -> [b] -> [[Char]]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
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" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
braceize ((b -> [Char]) -> [b] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> [Char]
showBox Int
0) [b]
ptrArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Word -> [Char]) -> [Word] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word -> [Char]
forall a. Show a => a -> [Char]
show [Word]
dataArgs)
BlockingQueueClosure {b
StgInfoTable
link :: forall b. GenClosure b -> b
blackHole :: 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
ptipe :: forall b. GenClosure b -> PrimType
intVal :: forall b. GenClosure b -> Int
intVal :: Int
ptipe :: PrimType
..} -> [[Char]] -> [Char]
app
[[Char]
"Int", Int -> [Char]
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", Word -> [Char]
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", Int64 -> [Char]
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", Word64 -> [Char]
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", Int -> [Char]
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", Float -> [Char]
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", Double -> [Char]
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
mccPtrs :: forall b. GenClosure b -> Word
mccPayload :: forall b. GenClosure b -> [b]
info :: forall b. GenClosure b -> StgInfoTable
..} -> [[Char]] -> [Char]
app
[[Char]
"[", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [[Char]]
shorten ((b -> [Char]) -> [b] -> [[Char]]
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
key :: forall b. GenClosure b -> b
finalizer :: 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 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " [[Char]]
xs)
shorten :: [[Char]] -> [[Char]]
shorten [[Char]]
xs = if [[Char]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 then Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
20 [[Char]]
xs [[Char]] -> [[Char]] -> [[Char]]
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) = GenClosure HeapTree -> Maybe (GenClosure HeapTree)
forall a. a -> Maybe a
Just GenClosure HeapTree
c
heapTreeClosure HeapTree
EndOfHeapTree = Maybe (GenClosure HeapTree)
forall a. Maybe a
Nothing
buildHeapTree :: Int -> Box -> IO HeapTree
buildHeapTree :: Int -> Box -> IO HeapTree
buildHeapTree Int
0 Box
_ = do
HeapTree -> IO HeapTree
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapTree -> IO HeapTree) -> HeapTree -> IO HeapTree
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' <- (Box -> IO HeapTree) -> Closure -> IO (GenClosure HeapTree)
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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Closure
c
HeapTree -> IO HeapTree
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapTree -> IO HeapTree) -> HeapTree -> IO HeapTree
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 = [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s
| Just [HeapTree]
l <- HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
t = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ((HeapTree -> [Char]) -> [HeapTree] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map HeapTree -> [Char]
ppHeapTree [HeapTree]
l) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
| Just [BCI HeapTree]
bc <- (HeapTree -> Maybe (GenClosure HeapTree))
-> GenClosure HeapTree -> Maybe [BCI HeapTree]
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" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (HeapTree -> [Char]) -> [HeapTree] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> HeapTree -> [Char]
go Int
10) ((BCI HeapTree -> [HeapTree]) -> [BCI HeapTree] -> [HeapTree]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BCI HeapTree -> [HeapTree]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [BCI HeapTree]
bc))
| Bool
otherwise = (Int -> HeapTree -> [Char]) -> Int -> GenClosure HeapTree -> [Char]
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 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([Char] -> [[Char]] -> [Char]
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 GenClosure HeapTree -> Bool
forall b. GenClosure b -> Bool
isNil GenClosure HeapTree
c
then [HeapTree] -> Maybe [HeapTree]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
(HeapTree
h,HeapTree
t) <- GenClosure HeapTree -> Maybe (HeapTree, HeapTree)
forall b. GenClosure b -> Maybe (b, b)
isCons GenClosure HeapTree
c
[HeapTree]
t' <- HeapTree -> Maybe [HeapTree]
isHeapTreeList HeapTree
t
[HeapTree] -> Maybe [HeapTree]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HeapTree] -> Maybe [HeapTree]) -> [HeapTree] -> Maybe [HeapTree]
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 ([HeapTree] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HeapTree]
list)
then Maybe [Char]
forall a. Maybe a
Nothing
else (HeapTree -> Maybe Char) -> [HeapTree] -> Maybe [Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenClosure HeapTree -> Maybe Char
forall b. GenClosure b -> Maybe Char
isChar (GenClosure HeapTree -> Maybe Char)
-> (HeapTree -> Maybe (GenClosure HeapTree))
-> HeapTree
-> Maybe Char
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 {
HeapGraphEntry a -> Box
hgeBox :: Box,
HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure :: GenClosure (Maybe HeapGraphIndex),
HeapGraphEntry a -> Bool
hgeLive :: Bool,
HeapGraphEntry a -> a
hgeData :: a}
deriving (Int -> HeapGraphEntry a -> [Char] -> [Char]
[HeapGraphEntry a] -> [Char] -> [Char]
HeapGraphEntry a -> [Char]
(Int -> HeapGraphEntry a -> [Char] -> [Char])
-> (HeapGraphEntry a -> [Char])
-> ([HeapGraphEntry a] -> [Char] -> [Char])
-> Show (HeapGraphEntry a)
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, a -> HeapGraphEntry b -> HeapGraphEntry a
(a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
(forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b)
-> (forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a)
-> Functor HeapGraphEntry
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
<$ :: a -> HeapGraphEntry b -> HeapGraphEntry a
$c<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
fmap :: (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]
[HeapGraph a] -> [Char] -> [Char]
HeapGraph a -> [Char]
(Int -> HeapGraph a -> [Char] -> [Char])
-> (HeapGraph a -> [Char])
-> ([HeapGraph a] -> [Char] -> [Char])
-> Show (HeapGraph a)
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 :: Int -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph Int
i (HeapGraph IntMap (HeapGraphEntry a)
m) = Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
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 :: Int -> a -> Box -> IO (HeapGraph a)
buildHeapGraph Int
limit a
rootD Box
initialBox =
(HeapGraph a, [(a, Int)]) -> HeapGraph a
forall a b. (a, b) -> a
fst ((HeapGraph a, [(a, Int)]) -> HeapGraph a)
-> IO (HeapGraph a, [(a, Int)]) -> IO (HeapGraph a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
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 :: Int -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
multiBuildHeapGraph Int
limit = Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
forall a.
Monoid a =>
Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit (IntMap (HeapGraphEntry a) -> HeapGraph a
forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
forall a. IntMap a
M.empty)
addHeapGraph
:: Monoid a
=> Int
-> a
-> Box
-> HeapGraph a
-> IO (HeapGraphIndex, HeapGraph a)
addHeapGraph :: 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)]) <- Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
forall a.
Monoid a =>
Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit HeapGraph a
hg [(a
d,Box
box)]
(Int, HeapGraph a) -> IO (Int, HeapGraph a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, HeapGraph a
hg')
annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
annotateHeapGraph :: a -> Int -> HeapGraph a -> HeapGraph a
annotateHeapGraph a
d Int
i (HeapGraph IntMap (HeapGraphEntry a)
hg) = IntMap (HeapGraphEntry a) -> HeapGraph a
forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph (IntMap (HeapGraphEntry a) -> HeapGraph a)
-> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a b. (a -> b) -> a -> b
$ (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> Int -> IntMap (HeapGraphEntry a) -> IntMap (HeapGraphEntry a)
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 = HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a. a -> Maybe a
Just (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a b. (a -> b) -> a -> b
$ HeapGraphEntry a
hge { hgeData :: a
hgeData = HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
hge a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
d }
generalBuildHeapGraph
:: Monoid a
=> Int
-> HeapGraph a
-> [(a,Box)]
-> IO (HeapGraph a, [(a, HeapGraphIndex)])
generalBuildHeapGraph :: Int -> HeapGraph a -> [(a, Box)] -> IO (HeapGraph a, [(a, Int)])
generalBuildHeapGraph Int
limit HeapGraph a
_ [(a, Box)]
_ | Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> IO (HeapGraph a, [(a, Int)])
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 = [ (HeapGraphEntry a -> Box
forall a. HeapGraphEntry a -> Box
hgeBox HeapGraphEntry a
hge, Int
i) | (Int
i, HeapGraphEntry a
hge) <- IntMap (HeapGraphEntry a) -> [(Int, HeapGraphEntry a)]
forall a. IntMap a -> [(Int, a)]
M.toList IntMap (HeapGraphEntry a)
hg ]
indices :: [Int]
indices | IntMap (HeapGraphEntry a) -> Bool
forall a. IntMap a -> Bool
M.null IntMap (HeapGraphEntry a)
hg = [Int
0..]
| Bool
otherwise = [Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, HeapGraphEntry a) -> Int
forall a b. (a, b) -> a
fst (IntMap (HeapGraphEntry a) -> (Int, HeapGraphEntry a)
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') <- WriterT (IntMap (HeapGraphEntry a)) IO [(a, Int)]
-> IO ([(a, Int)], IntMap (HeapGraphEntry a))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (StateT
([(Box, Int)], [Int], [Any])
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
-> ([(Box, Int)], [Int], [Any])
-> WriterT (IntMap (HeapGraphEntry a)) IO [(a, Int)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
([(Box, Int)], [Int], [Any])
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
forall c.
StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
run ([(Box, Int)], [Int], [Any])
forall a. ([(Box, Int)], [Int], [a])
initialState)
let hg'' :: HeapGraph a
hg'' = (HeapGraph a -> (a, Int) -> HeapGraph a)
-> HeapGraph a -> [(a, Int)] -> HeapGraph a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((a, Int) -> HeapGraph a -> HeapGraph a)
-> HeapGraph a -> (a, Int) -> HeapGraph a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> Int -> HeapGraph a -> HeapGraph a)
-> (a, Int) -> HeapGraph a -> HeapGraph a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Int -> HeapGraph a -> HeapGraph a
forall a. Monoid a => a -> Int -> HeapGraph a -> HeapGraph a
annotateHeapGraph)) (IntMap (HeapGraphEntry a) -> HeapGraph a
forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
hg') [(a, Int)]
is
(HeapGraph a, [(a, Int)]) -> IO (HeapGraph a, [(a, Int)])
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
WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
())
-> WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
()
forall a b. (a -> b) -> a -> b
$ IntMap (HeapGraphEntry a)
-> WriterT (IntMap (HeapGraphEntry a)) IO ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell IntMap (HeapGraphEntry a)
hg
[(a, Box)]
-> ((a, Box)
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(a, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(a, Box)]
addBoxes (((a, Box)
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(a, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)])
-> ((a, Box)
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(a, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
[(a, Int)]
forall a b. (a -> b) -> a -> b
$ \(a
d, Box
b) -> do
Just Int
i <- Int
-> Box
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
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
(a, Int)
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(a, Int)
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
_ = Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
add t
n Box
b = do
([(Box, Int)]
existing,[Int]
_,c
_) <- StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
([(Box, Int)], [Int], c)
forall (m :: * -> *) s. Monad m => StateT s m s
get
Maybe (Box, Int)
mbI <- IO (Maybe (Box, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe (Box, Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Box, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe (Box, Int)))
-> IO (Maybe (Box, Int))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe (Box, Int))
forall a b. (a -> b) -> a -> b
$ ((Box, Int) -> IO Bool) -> [(Box, Int)] -> IO (Maybe (Box, Int))
forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM (Box -> Box -> IO Bool
areBoxesEqual Box
b (Box -> IO Bool) -> ((Box, Int) -> Box) -> (Box, Int) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box, Int) -> Box
forall a b. (a, b) -> a
fst) [(Box, Int)]
existing
case Maybe (Box, Int)
mbI of
Just (Box
_,Int
i) -> Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int))
-> Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Maybe (Box, Int)
Nothing -> do
Int
i <- StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
Int
forall a b c.
StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
nextI
(([(Box, Int)], [Int], c) -> ([(Box, Int)], [Int], c))
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\([(Box, Int)]
x,[Int]
y,c
z) -> ((Box
b,Int
i)(Box, Int) -> [(Box, Int)] -> [(Box, Int)]
forall a. a -> [a] -> [a]
:[(Box, Int)]
x, [Int]
y, c
z))
Closure
c <- IO Closure
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Closure
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
Closure)
-> IO Closure
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
Closure
forall a b. (a -> b) -> a -> b
$ Box -> IO Closure
getBoxedClosureData Box
b
GenClosure (Maybe Int)
c' <- (Box
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int))
-> Closure
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(GenClosure (Maybe Int))
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
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)) Closure
c
WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
())
-> WriterT (IntMap (HeapGraphEntry a)) IO ()
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
()
forall a b. (a -> b) -> a -> b
$ IntMap (HeapGraphEntry a)
-> WriterT (IntMap (HeapGraphEntry a)) IO ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Int -> HeapGraphEntry a -> IntMap (HeapGraphEntry a)
forall a. Int -> a -> IntMap a
M.singleton Int
i (Box -> GenClosure (Maybe Int) -> Bool -> a -> HeapGraphEntry a
forall a.
Box -> GenClosure (Maybe Int) -> Bool -> a -> HeapGraphEntry a
HeapGraphEntry Box
b GenClosure (Maybe Int)
c' Bool
True a
forall a. Monoid a => a
mempty))
Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int))
-> Maybe Int
-> StateT
([(Box, Int)], [Int], c)
(WriterT (IntMap (HeapGraphEntry a)) IO)
(Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
nextI :: StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
nextI = do
b
i <- ((a, [b], c) -> b)
-> StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ([b] -> b
forall a. [a] -> a
head ([b] -> b) -> ((a, [b], c) -> [b]) -> (a, [b], c) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(a
_,[b]
b,c
_) -> [b]
b))
((a, [b], c) -> (a, [b], c))
-> StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\(a
a,[b]
b,c
c) -> (a
a, [b] -> [b]
forall a. [a] -> [a]
tail [b]
b, c
c))
b -> StateT (a, [b], c) (WriterT (IntMap (HeapGraphEntry a)) IO) b
forall (m :: * -> *) a. Monad m => a -> m a
return b
i
updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
updateHeapGraph :: Int -> HeapGraph a -> IO (HeapGraph a, Int -> Int)
updateHeapGraph Int
limit (HeapGraph IntMap (HeapGraphEntry a)
startHG) = do
(HeapGraph a
hg', IntMap Int
indexMap) <- WriterT (IntMap Int) IO (HeapGraph a)
-> IO (HeapGraph a, IntMap Int)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (IntMap Int) IO (HeapGraph a)
-> IO (HeapGraph a, IntMap Int))
-> WriterT (IntMap Int) IO (HeapGraph a)
-> IO (HeapGraph a, IntMap Int)
forall a b. (a -> b) -> a -> b
$ (HeapGraph a
-> (Int, HeapGraphEntry a)
-> WriterT (IntMap Int) IO (HeapGraph a))
-> HeapGraph a
-> [(Int, HeapGraphEntry a)]
-> WriterT (IntMap Int) IO (HeapGraph a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HeapGraph a
-> (Int, HeapGraphEntry a) -> WriterT (IntMap Int) IO (HeapGraph a)
forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
HeapGraph a
-> (Int, HeapGraphEntry a) -> WriterT (IntMap Int) m (HeapGraph a)
go (IntMap (HeapGraphEntry a) -> HeapGraph a
forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
forall a. IntMap a
M.empty) (IntMap (HeapGraphEntry a) -> [(Int, HeapGraphEntry a)]
forall a. IntMap a -> [(Int, a)]
M.toList IntMap (HeapGraphEntry a)
startHG)
(HeapGraph a, Int -> Int) -> IO (HeapGraph a, Int -> Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapGraph a
hg', IntMap Int -> Int -> Int
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') <- IO (Int, HeapGraph a) -> WriterT (IntMap Int) m (Int, HeapGraph a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, HeapGraph a)
-> WriterT (IntMap Int) m (Int, HeapGraph a))
-> IO (Int, HeapGraph a)
-> WriterT (IntMap Int) m (Int, HeapGraph a)
forall a b. (a -> b) -> a -> b
$ Int -> a -> Box -> HeapGraph a -> IO (Int, HeapGraph a)
forall a.
Monoid a =>
Int -> a -> Box -> HeapGraph a -> IO (Int, HeapGraph a)
addHeapGraph Int
limit (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
hge) (HeapGraphEntry a -> Box
forall a. HeapGraphEntry a -> Box
hgeBox HeapGraphEntry a
hge) HeapGraph a
hg
IntMap Int -> WriterT (IntMap Int) m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Int -> Int -> IntMap Int
forall a. Int -> a -> IntMap a
M.singleton Int
i Int
j)
HeapGraph a -> WriterT (IntMap Int) m (HeapGraph a)
forall (m :: * -> *) a. Monad m => a -> m a
return HeapGraph a
hg'
ppHeapGraph :: HeapGraph a -> String
ppHeapGraph :: HeapGraph a -> [Char]
ppHeapGraph (HeapGraph IntMap (HeapGraphEntry a)
m) = [Char]
letWrapper [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Maybe Int -> [Char]
ppRef Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
heapGraphRoot)
where
bindings :: [Int]
bindings = HeapGraph a -> [Int] -> [Int]
forall a. HeapGraph a -> [Int] -> [Int]
boundMultipleTimes (IntMap (HeapGraphEntry a) -> HeapGraph a
forall a. IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph IntMap (HeapGraphEntry a)
m) [Int
heapGraphRoot]
letWrapper :: [Char]
letWrapper =
if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
bindings
then [Char]
""
else [Char]
"let " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n " ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
ppBinding [Int]
bindings) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nin "
bindingLetter :: Int -> Char
bindingLetter Int
i = case HeapGraphEntry a -> GenClosure (Maybe Int)
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
n_args :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
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
n_args :: forall b. GenClosure b -> HalfWord
fun :: forall b. GenClosure b -> b
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
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
bcoptrs :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
bitmap :: forall b. GenClosure b -> [Word]
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 = [(Int, [Char])] -> IntMap [Char]
forall a. [(Int, a)] -> IntMap a
M.fromList ([(Int, [Char])] -> IntMap [Char])
-> [(Int, [Char])] -> IntMap [Char]
forall a b. (a -> b) -> a -> b
$
[[(Int, [Char])]] -> [(Int, [Char])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Int, [Char])]] -> [(Int, [Char])])
-> [[(Int, [Char])]] -> [(Int, [Char])]
forall a b. (a -> b) -> a -> b
$
([(Int, Char)] -> [(Int, [Char])])
-> [[(Int, Char)]] -> [[(Int, [Char])]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> (Int, Char) -> (Int, [Char]))
-> [Int] -> [(Int, Char)] -> [(Int, [Char])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
j (Int
i,Char
c) -> (Int
i, [Char
c] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
j)) [(Int
1::Int)..]) ([[(Int, Char)]] -> [[(Int, [Char])]])
-> [[(Int, Char)]] -> [[(Int, [Char])]]
forall a b. (a -> b) -> a -> b
$
((Int, Char) -> (Int, Char) -> Bool)
-> [(Int, Char)] -> [[(Int, Char)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Char -> Char -> Bool)
-> ((Int, Char) -> Char) -> (Int, Char) -> (Int, Char) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Char) -> Char
forall a b. (a, b) -> b
snd) ([(Int, Char)] -> [[(Int, Char)]])
-> [(Int, Char)] -> [[(Int, Char)]]
forall a b. (a -> b) -> a -> b
$
((Int, Char) -> (Int, Char) -> Ordering)
-> [(Int, Char)] -> [(Int, Char)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Char -> Char -> Ordering)
-> ((Int, Char) -> Char) -> (Int, Char) -> (Int, Char) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Char) -> Char
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 IntMap [Char] -> Int -> [Char]
forall a. IntMap a -> Int -> a
M.! Int
i
ppBinding :: Int -> [Char]
ppBinding Int
i = Int -> [Char]
ppVar Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [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 <- HeapGraphEntry a -> Maybe [Char]
forall a. HeapGraphEntry a -> Maybe [Char]
isString HeapGraphEntry a
hge = [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s
| Just [Maybe Int]
l <- HeapGraphEntry a -> Maybe [Maybe Int]
forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
hge = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ((Maybe Int -> [Char]) -> [Maybe Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> [Char]
ppRef Int
0) [Maybe Int]
l) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
| Just [BCI (Maybe Int)]
bc <- (Maybe Int -> Maybe (GenClosure (Maybe Int)))
-> GenClosure (Maybe Int) -> Maybe [BCI (Maybe Int)]
forall a b.
(a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO ((Int -> GenClosure (Maybe Int))
-> Maybe Int -> Maybe (GenClosure (Maybe Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure (HeapGraphEntry a -> GenClosure (Maybe Int))
-> (Int -> HeapGraphEntry a) -> Int -> GenClosure (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HeapGraphEntry a
iToE)) (HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
= [[Char]] -> [Char]
app ([Char]
"_bco" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Maybe Int -> [Char]) -> [Maybe Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> [Char]
ppRef Int
10) ((BCI (Maybe Int) -> [Maybe Int])
-> [BCI (Maybe Int)] -> [Maybe Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BCI (Maybe Int) -> [Maybe Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [BCI (Maybe Int)]
bc))
| Bool
otherwise = (Int -> Maybe Int -> [Char])
-> Int -> GenClosure (Maybe Int) -> [Char]
forall b. (Int -> b -> [Char]) -> Int -> GenClosure b -> [Char]
ppClosure Int -> Maybe Int -> [Char]
ppRef Int
prec (HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
where
app :: [[Char]] -> [Char]
app [[Char]
a] = [Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"()"
app [[Char]]
xs = Bool -> [Char] -> [Char]
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([Char] -> [[Char]] -> [Char]
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 Int -> [Int] -> Bool
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 IntMap (HeapGraphEntry a) -> Int -> HeapGraphEntry a
forall a. IntMap a -> Int -> a
M.! Int
i
iToUnboundE :: Int -> Maybe (HeapGraphEntry a)
iToUnboundE Int
i = if Int
i Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
bindings then Maybe (HeapGraphEntry a)
forall a. Maybe a
Nothing else Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap (HeapGraphEntry a)
m
isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
isList :: HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
hge =
if GenClosure (Maybe Int) -> Bool
forall b. GenClosure b -> Bool
isNil (HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure HeapGraphEntry a
hge)
then [Maybe Int] -> Maybe [Maybe Int]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
(Maybe Int
h,Maybe Int
t) <- GenClosure (Maybe Int) -> Maybe (Maybe Int, Maybe Int)
forall b. GenClosure b -> Maybe (b, b)
isCons (HeapGraphEntry a -> GenClosure (Maybe Int)
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' <- HeapGraphEntry a -> Maybe [Maybe Int]
forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
e
[Maybe Int] -> Maybe [Maybe Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Int] -> Maybe [Maybe Int])
-> [Maybe Int] -> Maybe [Maybe Int]
forall a b. (a -> b) -> a -> b
$ (:) Maybe Int
h [Maybe Int]
t'
isString :: HeapGraphEntry a -> Maybe String
isString :: HeapGraphEntry a -> Maybe [Char]
isString HeapGraphEntry a
e = do
[Maybe Int]
list <- HeapGraphEntry a -> Maybe [Maybe Int]
forall a. HeapGraphEntry a -> Maybe [Maybe Int]
isList HeapGraphEntry a
e
if ([Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe Int]
list)
then Maybe [Char]
forall a. Maybe a
Nothing
else (Maybe Int -> Maybe Char) -> [Maybe Int] -> Maybe [Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenClosure (Maybe Int) -> Maybe Char
forall b. GenClosure b -> Maybe Char
isChar (GenClosure (Maybe Int) -> Maybe Char)
-> (HeapGraphEntry a -> GenClosure (Maybe Int))
-> HeapGraphEntry a
-> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure (HeapGraphEntry a -> Maybe Char)
-> (Maybe Int -> Maybe (HeapGraphEntry a))
-> Maybe Int
-> Maybe Char
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> Maybe (HeapGraphEntry a)
iToUnboundE (Int -> Maybe (HeapGraphEntry a))
-> (Maybe Int -> Maybe Int)
-> Maybe Int
-> Maybe (HeapGraphEntry a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe Int -> Maybe Int
forall a. a -> a
id) [Maybe Int]
list
boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
boundMultipleTimes :: HeapGraph a -> [Int] -> [Int]
boundMultipleTimes (HeapGraph IntMap (HeapGraphEntry a)
m) [Int]
roots = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall a. [a] -> a
head ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ([Int] -> Bool) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. [a] -> [a]
tail ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
group ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
[Int]
roots [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (HeapGraphEntry a -> [Int]) -> [HeapGraphEntry a] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int])
-> (HeapGraphEntry a -> [Maybe Int]) -> HeapGraphEntry a -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenClosure (Maybe Int) -> [Maybe Int]
forall b. GenClosure b -> [b]
allClosures (GenClosure (Maybe Int) -> [Maybe Int])
-> (HeapGraphEntry a -> GenClosure (Maybe Int))
-> HeapGraphEntry a
-> [Maybe Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a -> GenClosure (Maybe Int)
forall a. HeapGraphEntry a -> GenClosure (Maybe Int)
hgeClosure) (IntMap (HeapGraphEntry a) -> [HeapGraphEntry a]
forall a. IntMap a -> [a]
M.elems IntMap (HeapGraphEntry a)
m)
disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
disassembleBCO a -> Maybe (GenClosure b)
_ GenClosure a
_ | Bool -> Bool
forall a. a -> a
id Bool
True = Maybe [BCI b]
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
instrs :: forall b. GenClosure b -> b
literals :: forall b. GenClosure b -> b
bcoptrs :: forall b. GenClosure b -> b
size :: forall b. GenClosure b -> HalfWord
bitmap :: forall b. GenClosure b -> [Word]
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
[BCI b] -> Maybe [BCI b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCI b] -> Maybe [BCI b]) -> [BCI b] -> Maybe [BCI b]
forall a b. (a -> b) -> a -> b
$ [b] -> [Word] -> ByteString -> [BCI b]
forall box. [box] -> [Word] -> ByteString -> [BCI box]
disassemble (GenClosure b -> [b]
forall b. GenClosure b -> [b]
mccPayload GenClosure b
ptrsC) (GenClosure b -> [Word]
forall b. GenClosure b -> [Word]
arrWords GenClosure b
litsC) (Word -> [Word] -> ByteString
toBytes (GenClosure b -> Word
forall b. GenClosure b -> Word
bytes GenClosure b
opsC) (GenClosure b -> [Word]
forall b. GenClosure b -> [Word]
arrWords GenClosure b
opsC))
disassembleBCO a -> Maybe (GenClosure b)
_ GenClosure a
_ = Maybe [BCI b]
forall a. Maybe a
Nothing
findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
_p [] = Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x) else (a -> IO Bool) -> [a] -> IO (Maybe a)
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]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> [Char] -> [Char]
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]
"{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"