{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Module      :  GHC.HeapView
Copyright   :  (c) 2012-2019 Joachim Breitner
License     :  BSD3
Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>

With this module, you can investigate the heap representation of Haskell
values, i.e. to investigate sharing and lazy evaluation.
-}


module GHC.HeapView (
    -- * Heap data types
    GenClosure(..),
    Closure,
    allClosures,                            -- was allPtrs
    ClosureType(..),
    StgInfoTable(..),
    HalfWord,
    -- * Reading from the heap
    getClosureData,
    getBoxedClosureData,
    getClosureRaw,
    -- * Pretty printing
    ppClosure,
    -- * Heap maps
    -- $heapmap
    HeapTree(..),
    buildHeapTree,
    ppHeapTree,
    HeapGraphEntry(..),
    HeapGraphIndex,
    HeapGraph(..),
    lookupHeapGraph,
    heapGraphRoot,
    buildHeapGraph,
    multiBuildHeapGraph,
    addHeapGraph,
    annotateHeapGraph,
    updateHeapGraph,
    ppHeapGraph,
    -- * Boxes
    Box(..),
    asBox,
    areBoxesEqual,
    -- * Disassembler
    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 for Functor, Foldable and Traversable is missing in  GHC 8.6
-- will be available in GHC 8.8
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,            -- Storable instance needed for EntryFunPtr!!
                 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              -- Storable instance needed for ItblCodes
              }

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 #)

-- | This returns the raw representation of the given argument. The second
-- component of the triple are the words on the heap, and the third component
-- are those words that are actually pointers. Once back in Haskell word, the
-- 'Word'  may be outdated after a garbage collector run, but the corresponding
-- 'Box' will still point to the correct value.
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
            -- This is just for good measure, and seems to be not important.
            (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
            -- This seems to be required to avoid crashes as well
            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
            -- The following deep evaluation is crucial to avoid crashes (but why)?
            (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)

-- From compiler/ghci/RtClosureInspect.hs
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

-- | A pretty-printer that tries to generate valid Haskell for evalutated data.
-- It assumes that for the included boxes, you already replaced them by Strings
-- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
--
-- The parameter gives the precedendence, to avoid avoidable parenthesises.
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
        --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
        [[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)
    -- copy-pasta'd from MutArrClosure:
    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
        --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
        [[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

{- $heapmap

   For more global views of the heap, you can use heap maps. These come in
   variations, either a trees or as graphs, depending on
   whether you want to detect cycles and sharing or not.

   The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
   operations expect this to be in the 'Monoid' class: They use 'mempty' to
   annotate closures added because the passed values reference them, and they
   use 'mappend' to combine the annotations when two values conincide, e.g.
   during 'updateHeapGraph'.
-}

-- | Heap maps as tree, i.e. no sharing, no cycles.
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

-- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
-- that prevents it from running ad infinitum for cyclic or infinite
-- structures.
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'

-- | Pretty-Printing a heap Tree
--
-- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
-- unevaluated expression depending on the command line argument.
--
-- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
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
    -- We do not want to print empty lists as "" as we do not know that they
    -- are really strings.
    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

-- | For heap graphs, i.e. data structures that also represent sharing and
-- cyclic structures, these are the entries. If the referenced value is
-- @Nothing@, then we do not have that value in the map, most likely due to
-- exceeding the recursion bound passed to 'buildHeapGraph'.
--
-- Besides a pointer to the stored value and the closure representation we
-- also keep track of whether the value was still alive at the last update of the
-- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
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

-- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
-- as the internal representation may change. Nevertheless, we export it here:
-- Sometimes the user knows better what he needs than we do.
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

-- | Creates a 'HeapGraph' for the value in the box, but not recursing further
-- than the given limit. The initial value has index 'heapGraphRoot'.
buildHeapGraph
   :: Monoid a
   => Int -- ^ Search limit
   -> a -- ^ Data value for the root
   -> Box -- ^ The value to start with
   -> 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)]

-- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
--   further than the given limit.
--
--   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
--   type @a@ can be used to make the connection between the input and the
--   resulting list of indices, and to store additional data.
multiBuildHeapGraph
    :: Monoid a
    => Int -- ^ Search limit
    -> [(a, Box)] -- ^ Starting values with associated data entry
    -> 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)

-- | Adds an entry to an existing 'HeapGraph'.
--
--   Returns the updated 'HeapGraph' and the index of the added value.
addHeapGraph
    :: Monoid a
    => Int -- ^ Search limit
    -> a -- ^ Data to be stored with the added value
    -> Box -- ^ Value to add to the graph
    -> HeapGraph a -- ^ Graph to extend
    -> 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')

-- | Adds the given annotation to the entry at the given index, using the
-- 'mappend' operation of its 'Monoid' instance.
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
    -- First collect all boxes from the existing heap graph
    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, [])
    -- It is ok to use the Monoid (IntMap a) instance here, because
    -- we will, besides the first time, use 'tell' only to add singletons not
    -- already there
    ([(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)
    -- Now add the annotations of the root values
    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 -- Start with the initial map
        [(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
            -- Cannot fail, as limit is not zero here
            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
        -- If the box is in the map, return the index
        ([(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
                -- Otherwise, allocate a new index
                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
                -- And register it
                (([(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))
                -- Look up the closure
                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
                -- Find indicies for all boxes contained in the map
                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
                -- Add add the resulting closure to the map
                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

-- | This function updates a heap graph to reflect the current state of
-- closures on the heap, conforming to the following specification.
--
--  * Every entry whose value has been garbage collected by now is marked as
--    dead by setting 'hgeLive' to @False@
--  * Every entry whose value is still live gets the 'hgeClosure' field updated
--    and newly referenced closures are, up to the given depth, added to the graph.
--  * A map mapping previous indicies to the corresponding new indicies is returned as well.
--  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'
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'

-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
--
-- >let x1 = "Ki"
-- >    x6 = C# 'H' : C# 'o' : x6
-- >in (x1,x1,x6)
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
    -- All variables occuring more than once
    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
        -- We do not want to print empty lists as "" as we do not know that they
        -- are really strings.
        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


-- | In the given HeapMap, list all indices that are used more than once. The
-- second parameter adds external references, commonly @[heapGraphRoot]@.
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)

-- | This function integrates the disassembler in "GHC.Disassembler". The first
-- argument should a function that dereferences the pointer in the closure to a
-- closure.
--
-- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing
disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
-- Disable the assembler
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

-- Utilities

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]
"}"