{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.Debug.Strings ( stringProgram, arrWordsProgram
                         , arrWordsAnalysis, stringAnalysis, decodeString) where

import GHC.Debug.Client
import GHC.Debug.Types.Ptr
import GHC.Debug.Trace
import GHC.Debug.Profile.Types
import Control.Monad.RWS
import qualified Data.Foldable as F

import qualified Data.Text as T
import qualified Data.Text.IO as T

import qualified Data.Map as Map
import qualified Data.Set as S
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS (length)
import Data.Char
import Data.Ord
import Data.List

-- | Find all the strings and then print out how many duplicates there are
stringProgram :: Debuggee -> IO ()
arrWordsProgram :: Debuggee -> IO ()
stringProgram :: Debuggee -> IO ()
stringProgram = (String -> Int)
-> ([ClosurePtr] -> DebugM (Map String (Set ClosurePtr)))
-> Debuggee
-> IO ()
forall a b.
Show a =>
(a -> Int)
-> ([ClosurePtr] -> DebugM (Map a (Set b))) -> Debuggee -> IO ()
programX String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClosurePtr] -> DebugM (Map String (Set ClosurePtr))
stringAnalysis
arrWordsProgram :: Debuggee -> IO ()
arrWordsProgram = (ByteString -> Int)
-> ([ClosurePtr] -> DebugM (Map ByteString (Set ClosurePtr)))
-> Debuggee
-> IO ()
forall a b.
Show a =>
(a -> Int)
-> ([ClosurePtr] -> DebugM (Map a (Set b))) -> Debuggee -> IO ()
programX (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> (ByteString -> Int64) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BS.length) [ClosurePtr] -> DebugM (Map ByteString (Set ClosurePtr))
arrWordsAnalysis

programX :: Show a => (a -> Int) -> ([ClosurePtr] -> DebugM (Map.Map a (S.Set b))) -> Debuggee -> IO ()
programX :: forall a b.
Show a =>
(a -> Int)
-> ([ClosurePtr] -> DebugM (Map a (Set b))) -> Debuggee -> IO ()
programX a -> Int
sizeOf [ClosurePtr] -> DebugM (Map a (Set b))
anal Debuggee
e = do
  Debuggee -> IO ()
pause Debuggee
e
  Map a (Set b)
res <- Debuggee -> DebugM (Map a (Set b)) -> IO (Map a (Set b))
forall a. Debuggee -> DebugM a -> IO a
runTrace Debuggee
e (DebugM (Map a (Set b)) -> IO (Map a (Set b)))
-> DebugM (Map a (Set b)) -> IO (Map a (Set b))
forall a b. (a -> b) -> a -> b
$ do
    DebugM [RawBlock]
precacheBlocks
    [ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
    Map a (Set b)
res <- [ClosurePtr] -> DebugM (Map a (Set b))
anal [ClosurePtr]
rs
    return Map a (Set b)
res
  Map a Count -> IO [a]
forall a. Show a => Map a Count -> IO [a]
printResult ((Set b -> Count) -> Map a (Set b) -> Map a Count
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Set b
s -> Int -> Count
Count (Set b -> Int
forall a. Set a -> Int
S.size Set b
s)) Map a (Set b)
res)
  Map a Count -> IO [a]
forall a. Show a => Map a Count -> IO [a]
printResult ((a -> Set b -> Count) -> Map a (Set b) -> Map a Count
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\a
k Set b
s -> Int -> Count
Count (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
sizeOf a
k) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Set b -> Int
forall a. Set a -> Int
S.size Set b
s))) Map a (Set b)
res)
  return ()

  {-
  let anal n = do
        let cools = fromJust (Map.lookup n res)
        print cools
        stacks <- run e $ do
          roots <- gcRoots
          rets <- findRetainersOf (Just (S.size cools)) roots (S.toList cools)
          rets' <- traverse (\c -> (show (head c),) <$> (addLocationToStack' c)) rets
          return rets'
        displayRetainerStack' stacks
        -}

-- | Find the parents of Bin nodes
stringAnalysis :: [ClosurePtr] -> DebugM (Map.Map String (S.Set ClosurePtr))
stringAnalysis :: [ClosurePtr] -> DebugM (Map String (Set ClosurePtr))
stringAnalysis [ClosurePtr]
rroots = (\(()
_, Map String (Set ClosurePtr)
r, ()
_) -> Map String (Set ClosurePtr)
r) (((), Map String (Set ClosurePtr), ())
 -> Map String (Set ClosurePtr))
-> DebugM ((), Map String (Set ClosurePtr), ())
-> DebugM (Map String (Set ClosurePtr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> Bool
-> Map String (Set ClosurePtr)
-> DebugM ((), Map String (Set ClosurePtr), ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
-> [ClosurePtr]
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
funcs [ClosurePtr]
rroots) Bool
False (Map String (Set ClosurePtr)
forall k a. Map k a
Map.empty)
  where
    funcs :: TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
funcs = (ClosurePtr
 -> SizedClosure
 -> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
 -> RWST Bool () (Map String (Set ClosurePtr)) DebugM ())
-> TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
closAccum

    -- First time we have visited a closure
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()
               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
closAccum ClosurePtr
cp SizedClosure
sc RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k = do
      case SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc of
        ConstrClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ [ClosurePtr]
_ [Word]
_ SrtCont
cd -> do
          ConstrDesc
cd' <- DebugM ConstrDesc
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ConstrDesc
forall (m :: * -> *) a.
Monad m =>
m a -> RWST Bool () (Map String (Set ClosurePtr)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM ConstrDesc
 -> RWST Bool () (Map String (Set ClosurePtr)) DebugM ConstrDesc)
-> DebugM ConstrDesc
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ConstrDesc
forall a b. (a -> b) -> a -> b
$ SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
cd
          case ConstrDesc
cd' of
            ConstrDesc String
_ String
_ String
cd2 | String
cd2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":" -> do
              ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
process ClosurePtr
cp SizedClosure
sc
            ConstrDesc
_ -> (Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall a.
(Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
False) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
        DebugClosure
  CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
_  -> (Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall a.
(Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
False) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
      where
        process :: ClosurePtr -> SizedClosure
                -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()
        process :: ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
process ClosurePtr
p_cp SizedClosure
clos = do
          DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos' <- DebugM
  (DebugClosure
     CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
-> RWST
     Bool
     ()
     (Map String (Set ClosurePtr))
     DebugM
     (DebugClosure
        CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST Bool () (Map String (Set ClosurePtr)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
   (DebugClosure
      CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
 -> RWST
      Bool
      ()
      (Map String (Set ClosurePtr))
      DebugM
      (DebugClosure
         CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))
-> DebugM
     (DebugClosure
        CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
-> RWST
     Bool
     ()
     (Map String (Set ClosurePtr))
     DebugM
     (DebugClosure
        CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall a b. (a -> b) -> a -> b
$ (CCSPtr -> DebugM CCSPtr)
-> (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
-> DebugM
     (DebugClosure
        CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosure a c e h j l
-> f (DebugClosure b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
clos)
          Bool
checked <- DebugM Bool
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM Bool
forall (m :: * -> *) a.
Monad m =>
m a -> RWST Bool () (Map String (Set ClosurePtr)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM Bool
 -> RWST Bool () (Map String (Set ClosurePtr)) DebugM Bool)
-> DebugM Bool
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM Bool
forall a b. (a -> b) -> a -> b
$ DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugM Bool
check_bin DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos'
          if Bool
checked
            then do
              Bool
parent_is_cons <- RWST Bool () (Map String (Set ClosurePtr)) DebugM Bool
forall r (m :: * -> *). MonadReader r m => m r
ask
              if Bool
parent_is_cons
                then (Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall a.
(Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
True) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
                else do
                  String
ds <- DebugM String
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM String
forall (m :: * -> *) a.
Monad m =>
m a -> RWST Bool () (Map String (Set ClosurePtr)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM String
 -> RWST Bool () (Map String (Set ClosurePtr)) DebugM String)
-> DebugM String
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM String
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> DebugM String
decodeString ClosurePtr
p_cp
                  (Map String (Set ClosurePtr) -> Map String (Set ClosurePtr))
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Set ClosurePtr -> Set ClosurePtr -> Set ClosurePtr)
-> String
-> Set ClosurePtr
-> Map String (Set ClosurePtr)
-> Map String (Set ClosurePtr)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set ClosurePtr -> Set ClosurePtr -> Set ClosurePtr
forall a. Semigroup a => a -> a -> a
(<>) String
ds (ClosurePtr -> Set ClosurePtr
forall a. a -> Set a
S.singleton ClosurePtr
p_cp))
                  (Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall a.
(Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
True) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
            else (Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
forall a.
(Bool -> Bool)
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
False) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k

        process_2 :: ClosurePtr -> DebugM Bool
process_2 ClosurePtr
p_cp = do
          SizedClosure
cp' <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
p_cp
          case SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
cp' of
            (ConstrClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ [ClosurePtr]
_ [Word]
_ SrtCont
cd) -> do
              (ConstrDesc String
_ String
_ String
cn) <- SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
cd
              Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"C#")
            (IndClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ ClosurePtr
i) ->
              ClosurePtr -> DebugM Bool
process_2 ClosurePtr
i
            DebugClosure
  CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        check_bin :: DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugM Bool
check_bin (ConstrClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ [ClosurePtr
h,ClosurePtr
_] [Word]
_ (ConstrDesc String
_ String
_ String
":")) = ClosurePtr -> DebugM Bool
process_2 ClosurePtr
h
        check_bin (IndClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ ClosurePtr
i) = do
          SizedClosure
sizedI <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
i
          DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos' <- (CCSPtr -> DebugM CCSPtr)
-> (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
-> DebugM
     (DebugClosure
        CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosure a c e h j l
-> f (DebugClosure b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sizedI)
          DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugM Bool
check_bin DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos'
        check_bin DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
_ = Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

decodeString :: ClosurePtr -> DebugM String
decodeString :: ClosurePtr -> DebugM String
decodeString ClosurePtr
cp = do
  SizedClosure
cp' <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
  case SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
cp' of
    (IndClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ ClosurePtr
i) -> ClosurePtr -> DebugM String
decodeString ClosurePtr
i
    (ConstrClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ [ClosurePtr
p,ClosurePtr
ps] [Word]
_ SrtCont
_) -> do
      ClosurePtr -> ClosurePtr -> DebugM String
go ClosurePtr
p ClosurePtr
ps
    DebugClosure
  CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> String -> DebugM String
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    where
  go :: ClosurePtr -> ClosurePtr -> DebugM String
go ClosurePtr
headp ClosurePtr
tailp = do
    SizedClosure
cp'' <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
headp
    case SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
cp'' of
      (IndClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ ClosurePtr
i) -> ClosurePtr -> ClosurePtr -> DebugM String
go ClosurePtr
i ClosurePtr
tailp
      (ConstrClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ [ClosurePtr]
_ [Word
w] SrtCont
_) -> do
        (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> DebugM String -> DebugM String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClosurePtr -> DebugM String
decodeString ClosurePtr
tailp
      DebugClosure
  CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> String -> DebugM String
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return []


printResult :: Show a => Map.Map a Count -> IO [a]
printResult :: forall a. Show a => Map a Count -> IO [a]
printResult Map a Count
m = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"TOTAL: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Count -> String
forall a. Show a => a -> String
show Count
total
  ((a, Count) -> IO ()) -> [(a, Count)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (a, Count) -> IO ()
forall {a}. Show a => (a, Count) -> IO ()
show_line [(a, Count)]
top10
  return (((a, Count) -> a) -> [(a, Count)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Count) -> a
forall a b. (a, b) -> a
fst [(a, Count)]
top10)
  where
    show_line :: (a, Count) -> IO ()
show_line (a
k, Count Int
v) = Text -> IO ()
T.putStrLn (String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
v))
    top10 :: [(a, Count)]
top10 = Int -> [(a, Count)] -> [(a, Count)]
forall a. Int -> [a] -> [a]
take Int
1000 ([(a, Count)] -> [(a, Count)]) -> [(a, Count)] -> [(a, Count)]
forall a b. (a -> b) -> a -> b
$ [(a, Count)] -> [(a, Count)]
forall a. [a] -> [a]
reverse (((a, Count) -> (a, Count) -> Ordering)
-> [(a, Count)] -> [(a, Count)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, Count) -> Count) -> (a, Count) -> (a, Count) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, Count) -> Count
forall a b. (a, b) -> b
snd) (Map a Count -> [(a, Count)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a Count
m))
    total :: Count
total = [Count] -> Count
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (Map a Count -> [Count]
forall k a. Map k a -> [a]
Map.elems Map a Count
m)

-- | Find how many distinct ArrWords there are
arrWordsAnalysis :: [ClosurePtr] -> DebugM (Map.Map ByteString (S.Set ClosurePtr))
arrWordsAnalysis :: [ClosurePtr] -> DebugM (Map ByteString (Set ClosurePtr))
arrWordsAnalysis [ClosurePtr]
rroots = (\(()
_, Map ByteString (Set ClosurePtr)
r, ()
_) -> Map ByteString (Set ClosurePtr)
r) (((), Map ByteString (Set ClosurePtr), ())
 -> Map ByteString (Set ClosurePtr))
-> DebugM ((), Map ByteString (Set ClosurePtr), ())
-> DebugM (Map ByteString (Set ClosurePtr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
-> ()
-> Map ByteString (Set ClosurePtr)
-> DebugM ((), Map ByteString (Set ClosurePtr), ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
-> [ClosurePtr]
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
funcs [ClosurePtr]
rroots) () (Map ByteString (Set ClosurePtr)
forall k a. Map k a
Map.empty)
  where
    funcs :: TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
funcs = (ClosurePtr
 -> SizedClosure
 -> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
 -> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ())
-> TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr
-> SizedClosure
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
closAccum

    -- First time we have visited a closure
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()
               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
closAccum ClosurePtr
cp SizedClosure
sc RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
k = do
          case (SizedClosure
-> DebugClosure
     CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc) of
            ArrWordsClosure StgInfoTableWithPtr
_ Maybe (ProfHeader CCSPtr)
_ Word
_ [Word]
p ->  do
              (Map ByteString (Set ClosurePtr)
 -> Map ByteString (Set ClosurePtr))
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Set ClosurePtr -> Set ClosurePtr -> Set ClosurePtr)
-> ByteString
-> Set ClosurePtr
-> Map ByteString (Set ClosurePtr)
-> Map ByteString (Set ClosurePtr)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set ClosurePtr -> Set ClosurePtr -> Set ClosurePtr
forall a. Semigroup a => a -> a -> a
(<>) ([Word] -> ByteString
arrWordsBS [Word]
p) (ClosurePtr -> Set ClosurePtr
forall a. a -> Set a
S.singleton ClosurePtr
cp))
              RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
k
            DebugClosure
  CCSPtr SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
k