{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.Debug.Strings ( stringProgram, arrWordsProgram
                         , arrWordsAnalysis, stringAnalysis) 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 = forall a b.
Show a =>
(a -> Int)
-> ([ClosurePtr] -> DebugM (Map a (Set b))) -> Debuggee -> IO ()
programX forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClosurePtr] -> DebugM (Map String (Set ClosurePtr))
stringAnalysis
arrWordsProgram :: Debuggee -> IO ()
arrWordsProgram = forall a b.
Show a =>
(a -> Int)
-> ([ClosurePtr] -> DebugM (Map a (Set b))) -> Debuggee -> IO ()
programX (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 <- 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
    Map a (Set b)
res <- [ClosurePtr] -> DebugM (Map a (Set b))
anal [ClosurePtr]
rs
    return Map a (Set b)
res
  forall a. Show a => Map a Count -> IO [a]
printResult (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Set b
s -> Int -> Count
Count (forall a. Set a -> Int
S.size Set b
s)) Map a (Set b)
res)
  forall a. Show a => Map a Count -> IO [a]
printResult (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\a
k Set b
s -> Int -> Count
Count (forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
sizeOf a
k) forall a. Num a => a -> a -> a
* (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
funcs [ClosurePtr]
rroots) Bool
False (forall k a. Map k a
Map.empty)
  where
    funcs :: TraceFunctions (RWST Bool () (Map String (Set ClosurePtr)))
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
papTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
srtTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
stackTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
closAccum
              , visitedVal :: ClosurePtr -> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
visitedVal = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc -> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
conDescTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }

    -- 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 forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
sc of
        ConstrClosure StgInfoTableWithPtr
_ [ClosurePtr]
_ [Word]
_ SrtCont
cd -> do
          ConstrDesc
cd' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
cd
          case ConstrDesc
cd' of
            ConstrDesc String
_ String
_ String
cd2 | String
cd2 forall a. Eq a => a -> a -> Bool
== String
":" -> do
              ClosurePtr
-> SizedClosure
-> RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
process ClosurePtr
cp SizedClosure
sc
            ConstrDesc
_ -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const Bool
False) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
        DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_  -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (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 SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos' <- 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. Monad m => a -> m a
return (forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
clos)
          Bool
checked <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall {srt} {pap} {s}.
DebugClosure srt pap ConstrDesc s ClosurePtr -> DebugM Bool
check_bin DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
clos'
          if Bool
checked
            then do
              Bool
parent_is_cons <- forall r (m :: * -> *). MonadReader r m => m r
ask
              if Bool
parent_is_cons
                then forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const Bool
True) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
                else do
                  String
ds <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ClosurePtr -> DebugM String
decodeString ClosurePtr
p_cp
                  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (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
(<>) String
ds (forall a. a -> Set a
S.singleton ClosurePtr
p_cp))
                  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const Bool
True) RWST Bool () (Map String (Set ClosurePtr)) DebugM ()
k
            else forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (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 forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
cp' of
            (ConstrClosure StgInfoTableWithPtr
_ [ClosurePtr]
_ [Word]
_ SrtCont
cd) -> do
              (ConstrDesc String
_ String
_ String
cn) <- SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
cd
              forall (m :: * -> *) a. Monad m => a -> m a
return (String
cn forall a. Eq a => a -> a -> Bool
== String
"C#")
            DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        check_bin :: DebugClosure srt pap ConstrDesc s ClosurePtr -> DebugM Bool
check_bin (ConstrClosure StgInfoTableWithPtr
_ [ClosurePtr
h,ClosurePtr
_] [Word]
_ (ConstrDesc String
_ String
_ String
":")) = ClosurePtr -> DebugM Bool
process_2 ClosurePtr
h
        check_bin DebugClosure srt pap ConstrDesc s ClosurePtr
_ = 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 forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
cp' of
    (ConstrClosure StgInfoTableWithPtr
_ [ClosurePtr
p,ClosurePtr
ps] [Word]
_ SrtCont
_) -> do
      SizedClosure
cp'' <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
p
      case forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
cp'' of
        (ConstrClosure StgInfoTableWithPtr
_ [ClosurePtr]
_ [Word
w] SrtCont
_) -> do
          (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClosurePtr -> DebugM String
decodeString ClosurePtr
ps
        DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> 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 forall a b. (a -> b) -> a -> b
$ String
"TOTAL: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Count
total
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. Show a => (a, Count) -> IO ()
show_line [(a, Count)]
top10
  return (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a. Show a => a -> String
show a
k) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
v))
    top10 :: [(a, Count)]
top10 = forall a. Int -> [a] -> [a]
take Int
1000 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
Map.toList Map a Count
m))
    total :: Count
total = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
funcs [ClosurePtr]
rroots) () (forall k a. Map k a
Map.empty)
  where
    funcs :: TraceFunctions (RWST () () (Map ByteString (Set ClosurePtr)))
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
papTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
srtTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
stackTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
closAccum
              , visitedVal :: ClosurePtr
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
visitedVal = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc
-> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
conDescTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }

    -- 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 (forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
sc) of
            ArrWordsClosure StgInfoTableWithPtr
_ Word
_ [Word]
p ->  do
              forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (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
(<>) ([Word] -> ByteString
arrWordsBS [Word]
p) (forall a. a -> Set a
S.singleton ClosurePtr
cp))
              RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
k
            DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> RWST () () (Map ByteString (Set ClosurePtr)) DebugM ()
k