{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{- | Functions for performing whole heap census in the style of the normal
- heap profiling -}
module GHC.Debug.Profile( profile
                        , censusClosureType
                        , census2LevelClosureType
                        , closureCensusBy
                        , CensusByClosureType
                        , writeCensusByClosureType
                        , CensusStats(..)
                        , mkCS
                        , Count(..)
                        , closureToKey ) where

import GHC.Debug.Client.Monad
import GHC.Debug.Client
import GHC.Debug.Trace
import GHC.Debug.ParTrace
import GHC.Debug.Profile.Types

import qualified Data.Map.Strict as Map
import Control.Monad.State
import Data.List (sortBy)
import Data.Ord
import Control.Concurrent
import Eventlog.Types
import Eventlog.Data
import Eventlog.Total
import Eventlog.HtmlTemplate
import Eventlog.Args (defaultArgs, Option(..))
import Data.Text (pack, Text, unpack)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Map.Monoidal.Strict as MMap
import Data.Bitraversable


type CensusByClosureType = Map.Map Text CensusStats

-- | Perform a heap census in the same style as the -hT profile.
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType = forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go
  where
    go :: ClosurePtr -> SizedClosure
       -> DebugM (Maybe (Text, CensusStats))
    go :: ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go ClosurePtr
_ SizedClosure
s = do
      DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d <- forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      let siz :: Size
          siz :: Size
siz = forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
siz
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d), CensusStats
v)



closureToKey :: DebugClosure srt a ConstrDesc c d -> Text
closureToKey :: forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey DebugClosure srt a ConstrDesc c d
d =
  case DebugClosure srt a ConstrDesc c d
d of
     ConstrClosure { constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc String
a String
b String
c }
       -> String -> Text
pack String
a forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
b forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
c
     DebugClosure srt a ConstrDesc c d
_ -> String -> Text
pack (forall a. Show a => a -> String
show (StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable (forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info DebugClosure srt a ConstrDesc c d
d))))


-- | General function for performing a heap census in constant memory
closureCensusBy :: forall k v . (Semigroup v, Ord k)
                => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
                -> [ClosurePtr] -> DebugM (Map.Map k v)
closureCensusBy :: forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))
f [ClosurePtr]
cps = do
  () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DebugM [RawBlock]
precacheBlocks
  forall k a. MonoidalMap k a -> Map k a
MMap.getMonoidalMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () (MonoidalMap k v)
funcs (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo ()) [ClosurePtr]
cps)
  where
    funcs :: TraceFunctionsIO () (MonoidalMap k v)
funcs = TraceFunctionsIO {
               papTrace :: GenPapPayload ClosurePtr -> DebugM ()
papTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr -> DebugM ()
srtTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr -> DebugM ()
stackTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), MonoidalMap k v, DebugM () -> DebugM ())
closTrace = forall a.
ClosurePtr
-> SizedClosure -> () -> DebugM ((), MonoidalMap k v, a -> a)
closAccum
              , visitedVal :: ClosurePtr -> () -> DebugM (MonoidalMap k v)
visitedVal = forall a b. a -> b -> a
const (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. MonoidalMap k a
MMap.empty))
              , conDescTrace :: ConstrDesc -> DebugM ()
conDescTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> ()
               -> DebugM ((), MMap.MonoidalMap k v, a -> a)
    closAccum :: forall a.
ClosurePtr
-> SizedClosure -> () -> DebugM ((), MonoidalMap k v, a -> a)
closAccum ClosurePtr
cp SizedClosure
s () = do
      Maybe (k, v)
r <- ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))
f ClosurePtr
cp SizedClosure
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\MonoidalMap k v
s' -> ((), MonoidalMap k v
s', forall a. a -> a
id)) forall a b. (a -> b) -> a -> b
$ case Maybe (k, v)
r of
        Just (k
k, v
v) -> forall k a. k -> a -> MonoidalMap k a
MMap.singleton k
k v
v
        Maybe (k, v)
Nothing -> forall k a. MonoidalMap k a
MMap.empty

-- | Perform a 2-level census where the keys are the type of the closure
-- in addition to the type of ptrs of the closure. This can be used to
-- distinguish between lists of different type for example.
census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType [ClosurePtr]
cps = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (StateT CensusByClosureType)
funcs [ClosurePtr]
cps) forall k a. Map k a
Map.empty
  where
    funcs :: TraceFunctions (StateT CensusByClosureType)
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
papTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
srtTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr
-> StateT CensusByClosureType DebugM ()
stackTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum
              , visitedVal :: ClosurePtr -> StateT CensusByClosureType DebugM ()
visitedVal = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc -> StateT CensusByClosureType DebugM ()
conDescTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (StateT CensusByClosureType DebugM) ()
               -> (StateT CensusByClosureType DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum ClosurePtr
_ SizedClosure
s StateT CensusByClosureType DebugM ()
k = do
      DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload SrtCont -> DebugM ConstrDesc
dereferenceConDesc (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr)
dereferenceStack) forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      [SizedClosure]
pts <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ClosurePtr -> DebugM SizedClosure
dereferenceClosure (forall c a.
DebugClosure
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s'))
      [DebugClosureWithExtra
   Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
pts


      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall {srt} {pap} {s} {b} {srt} {a} {c} {d}.
DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' [DebugClosureWithExtra
   Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts')
      StateT CensusByClosureType DebugM ()
k

    go :: DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithSize srt pap ConstrDesc s b
d [DebugClosureWithSize srt a ConstrDesc c d]
args =
      let k :: Text
k = forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap ConstrDesc s b
d)
          kargs :: [Text]
kargs = forall a b. (a -> b) -> [a] -> [b]
map (forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize) [DebugClosureWithSize srt a ConstrDesc c d]
args
          final_k :: Text
          final_k :: Text
final_k = Text
k forall a. Semigroup a => a -> a -> a
<> Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
kargs forall a. Semigroup a => a -> a -> a
<> Text
"]"
      in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) Text
final_k (Size -> CensusStats
mkCS (forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithSize srt pap ConstrDesc s b
d))

{-
-- | Parallel heap census
parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats)
parCensus bs cs =  do
  MMap.getMonoidalMap <$> (traceParFromM bs funcs (map (ClosurePtrWithInfo ()) cs))

  where
    nop = const (return ())
    funcs = TraceFunctionsIO nop nop clos  (const (const (return mempty))) nop

    clos :: ClosurePtr -> SizedClosure -> ()
              -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())
    clos _cp sc () = do
      d <- quintraverse pure dereferenceConDesc pure pure sc
      let s :: Size
          s = dcSize sc
          v =  mkCS s
      return $ ((), MMap.singleton (closureToKey (noSize d)) v, id)
      -}


writeCensusByClosureType :: FilePath -> CensusByClosureType -> IO ()
writeCensusByClosureType :: String -> CensusByClosureType -> IO ()
writeCensusByClosureType String
outpath CensusByClosureType
c = do
  let res :: [(Text, CensusStats)]
res = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CensusStats -> Size
cssize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))) (forall k a. Map k a -> [(k, a)]
Map.toList CensusByClosureType
c)
      showLine :: (Text, CensusStats) -> String
showLine (Text
k, CS (Count Int
n) (Size Int
s) (Max (Size Int
mn))) =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Text -> String
unpack Text
k, String
":", forall a. Show a => a -> String
show Int
s,String
":", forall a. Show a => a -> String
show Int
n, String
":", forall a. Show a => a -> String
show Int
mn,String
":", forall a. Show a => a -> String
show @Double (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)]
  String -> String -> IO ()
writeFile String
outpath ([String] -> String
unlines forall a b. (a -> b) -> a -> b
$ String
"key, total, count, max, avg" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text, CensusStats) -> String
showLine [(Text, CensusStats)]
res)


-- | Peform a profile at the given interval (in seconds), the result will
-- be rendered after each iteration using @eventlog2html@.
profile :: FilePath -> Int -> Debuggee -> IO ()
profile :: String -> Int -> Debuggee -> IO ()
profile String
outpath Int
interval Debuggee
e = [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int
0, forall k a. Map k a
Map.empty)] Int
0
  where
    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()
    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int, CensusByClosureType)]
ss Int
i = do
      Int -> IO ()
threadDelay (Int
interval forall a. Num a => a -> a -> a
* Int
1_000_000)
      Debuggee -> IO ()
pause Debuggee
e
      CensusByClosureType
r <- forall a. Debuggee -> DebugM a -> IO a
runTrace Debuggee
e forall a b. (a -> b) -> a -> b
$ do
        DebugM [RawBlock]
precacheBlocks
        [ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
        forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClosurePtr]
rs)
        [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType [ClosurePtr]
rs
      Debuggee -> IO ()
resume Debuggee
e
      String -> CensusByClosureType -> IO ()
writeCensusByClosureType String
outpath CensusByClosureType
r
      let new_data :: [(Int, CensusByClosureType)]
new_data = ((Int
i forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
interval, CensusByClosureType
r) forall a. a -> [a] -> [a]
: [(Int, CensusByClosureType)]
ss
      [(Int, CensusByClosureType)] -> IO ()
renderProfile [(Int, CensusByClosureType)]
new_data
      [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int, CensusByClosureType)]
new_data (Int
i forall a. Num a => a -> a -> a
+ Int
1)


mkFrame :: (Int, CensusByClosureType) -> Frame
mkFrame :: (Int, CensusByClosureType) -> Frame
mkFrame (Int
t, CensusByClosureType
m) = Double -> [Sample] -> Frame
Frame (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t forall a. Fractional a => a -> a -> a
/ Double
10e6) (forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\Text
k CensusStats
v [Sample]
r -> Text -> CensusStats -> Sample
mkSample Text
k CensusStats
v forall a. a -> [a] -> [a]
: [Sample]
r) [] CensusByClosureType
m)

mkSample :: Text -> CensusStats -> Sample
mkSample :: Text -> CensusStats -> Sample
mkSample Text
k (CS Count
_ (Size Int
v) Max Size
_) =
  Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
k) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)

mkProfData :: [(Int, CensusByClosureType)] -> ProfData
mkProfData :: [(Int, CensusByClosureType)] -> ProfData
mkProfData [(Int, CensusByClosureType)]
raw_fs =
  let fs :: [Frame]
fs = forall a b. (a -> b) -> [a] -> [b]
map (Int, CensusByClosureType) -> Frame
mkFrame [(Int, CensusByClosureType)]
raw_fs
      (Int
counts, Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals) = [Frame]
-> (Int,
    Map Bucket (Double, Double, Maybe (Double, Double, Double)))
total [Frame]
fs
      -- Heap profiles don't contain any other information than the simple bucket name
      binfo :: Map Bucket BucketInfo
binfo = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\(Bucket Text
k) (Double
t,Double
s,Maybe (Double, Double, Double)
g) -> Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
k forall a. Maybe a
Nothing Double
t Double
s Maybe (Double, Double, Double)
g) Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals
  -- Heap profiles do not support traces
      header :: Header
header = Text
-> Text
-> Maybe HeapProfBreakdown
-> Text
-> Text
-> Text
-> Int
-> Maybe String
-> Header
Header Text
"ghc-debug" Text
"" (forall a. a -> Maybe a
Just HeapProfBreakdown
HeapProfBreakdownClosureType) Text
"" Text
"" Text
"" Int
counts forall a. Maybe a
Nothing
  in Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> HeapInfo
-> Map InfoTablePtr InfoTableLoc
-> ProfData
ProfData Header
header Map Bucket BucketInfo
binfo forall a. Monoid a => a
mempty [Frame]
fs [] ([HeapSample] -> [HeapSample] -> [HeapSample] -> HeapInfo
HeapInfo [] [] []) forall a. Monoid a => a
mempty

renderProfile :: [(Int, CensusByClosureType)] -> IO ()
renderProfile :: [(Int, CensusByClosureType)] -> IO ()
renderProfile [(Int, CensusByClosureType)]
ss = do
  let pd :: ProfData
pd = [(Int, CensusByClosureType)] -> ProfData
mkProfData [(Int, CensusByClosureType)]
ss
  Run Args
as <- String -> IO Option
defaultArgs String
"unused"
  (Header
header, Value
data_json, Maybe Value
descs, Maybe Html
closure_descs) <- Args -> ProfData -> IO (Header, Value, Maybe Value, Maybe Html)
generateJsonData Args
as ProfData
pd
  let html :: String
html = Header -> Value -> Maybe Value -> Maybe Html -> Args -> String
templateString Header
header Value
data_json Maybe Value
descs Maybe Html
closure_descs Args
as
  String -> String -> IO ()
writeFile String
"profile/ht.html" String
html
  return ()