{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
-- | Attempt to find duplicate objects on the heap. The analysis is not
-- exact but attempts to find closures which are identical, and could be
-- shared.
module GHC.Debug.ObjectEquiv(objectEquiv, objectEquivAnalysis, printObjectEquiv, EquivMap) where

import GHC.Debug.Client.Monad
import GHC.Debug.Client
import GHC.Debug.Trace
import GHC.Debug.Profile
import GHC.Debug.Types.Graph (ppClosure)
import GHC.Debug.Types(ClosurePtr(..))

import Control.Monad.State
import Data.List (sortBy)
import Data.Ord
import Debug.Trace
import qualified Data.OrdPSQ as PS
import qualified Data.IntMap.Strict as IM
import Data.List.NonEmpty(NonEmpty(..))

type CensusByObjectEquiv = IM.IntMap CensusStats

-- | How big to allow the priority queue to grow to
limit :: Int
limit :: Int
limit = Int
100_000
-- | How many times an object must appear per 100 000 closures to be
-- "interesting" and kept for the future.
of_interest :: Int
of_interest :: Int
of_interest = Int
1000

-- Pick a representative ClosurePtr for each object
type EquivMap = PS.OrdPSQ PtrClosure -- Object
                           Int
                           ClosurePtr -- Representative of equivalence class

type Equiv2Map = IM.IntMap -- Pointer
                  ClosurePtr -- Representative of equivalence class

data ObjectEquivState = ObjectEquivState  {
                            ObjectEquivState -> EquivMap
emap   :: !EquivMap
                          , ObjectEquivState -> Equiv2Map
emap2 :: !Equiv2Map
                          , ObjectEquivState -> CensusByObjectEquiv
_census :: !CensusByObjectEquiv
                          }
-- Don't need to add identity mapping in emap2 because lookup failure is
-- the identity anyway.
addEquiv :: ClosurePtr -> PtrClosure -> ObjectEquivState -> ObjectEquivState
addEquiv :: ClosurePtr -> PtrClosure -> ObjectEquivState -> ObjectEquivState
addEquiv ClosurePtr
cp PtrClosure
pc (ObjectEquivState -> ObjectEquivState
trimMap -> ObjectEquivState
o) =
                  let (Either ClosurePtr ClosurePtr
res, EquivMap
new_m) = forall k p v b.
(Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> OrdPSQ k p v -> (b, OrdPSQ k p v)
PS.alter Maybe (Int, ClosurePtr)
-> (Either ClosurePtr ClosurePtr, Maybe (Int, ClosurePtr))
g PtrClosure
pc (ObjectEquivState -> EquivMap
emap ObjectEquivState
o)
                      new_emap2 :: Equiv2Map
new_emap2 = case Either ClosurePtr ClosurePtr
res of
                                     Left ClosurePtr
_ -> ObjectEquivState -> Equiv2Map
emap2 ObjectEquivState
o
                                     -- Only remap objects which have a hit
                                     -- in the cache
                                     Right ClosurePtr
new_cp -> ClosurePtr -> ClosurePtr -> Equiv2Map -> Equiv2Map
addNewMap ClosurePtr
cp ClosurePtr
new_cp (ObjectEquivState -> Equiv2Map
emap2 ObjectEquivState
o)
                  in ( ObjectEquivState
o { emap :: EquivMap
emap = EquivMap
new_m
                      , emap2 :: Equiv2Map
emap2 = Equiv2Map
new_emap2 })
  where
    g :: Maybe (Int, ClosurePtr)
-> (Either ClosurePtr ClosurePtr, Maybe (Int, ClosurePtr))
g Maybe (Int, ClosurePtr)
Nothing = (forall a b. a -> Either a b
Left ClosurePtr
cp, forall a. a -> Maybe a
Just (Int
0, ClosurePtr
cp))
    g (Just (Int
p, ClosurePtr
v)) = (forall a b. b -> Either a b
Right ClosurePtr
v, forall a. a -> Maybe a
Just (Int
p forall a. Num a => a -> a -> a
+ Int
1, ClosurePtr
v))

addNewMap :: ClosurePtr -> ClosurePtr -> Equiv2Map -> Equiv2Map
addNewMap :: ClosurePtr -> ClosurePtr -> Equiv2Map -> Equiv2Map
addNewMap (ClosurePtr Word64
cp) ClosurePtr
equiv_cp Equiv2Map
o = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cp) ClosurePtr
equiv_cp Equiv2Map
o

-- Trim down map to keep objects which have only been seen 100 times or
-- more within the last 10 000 seen objects
trimMap :: ObjectEquivState -> ObjectEquivState
trimMap :: ObjectEquivState -> ObjectEquivState
trimMap ObjectEquivState
o = if ObjectEquivState -> Int
checkSize ObjectEquivState
o forall a. Ord a => a -> a -> Bool
> Int
limit
              then let new_o :: ObjectEquivState
new_o = ObjectEquivState
o { emap :: EquivMap
emap = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k p v.
(Ord k, Ord p) =>
p -> OrdPSQ k p v -> ([(k, p, v)], OrdPSQ k p v)
PS.atMostView Int
of_interest (ObjectEquivState -> EquivMap
emap ObjectEquivState
o) }
                   in forall a b. Show a => a -> b -> b
traceShow (ObjectEquivState -> Int
checkSize ObjectEquivState
new_o) ObjectEquivState
new_o
                   -- TODO: Here would be good to also keep everything
                   -- which is referenced by the kept closures, otherwise
                   -- you end up with duplicates in the map

              else ObjectEquivState
o

-- | O(1) due to psqueues implementation
checkSize :: ObjectEquivState -> Int
checkSize :: ObjectEquivState -> Int
checkSize (ObjectEquivState EquivMap
e1 Equiv2Map
_ CensusByObjectEquiv
_) = forall k p v. OrdPSQ k p v -> Int
PS.size EquivMap
e1

type PtrClosure = DebugClosureWithSize PapPayload ConstrDesc StackFrames ClosurePtr

-- | General function for performing a heap census in constant memory
censusObjectEquiv :: [ClosurePtr] -> DebugM ObjectEquivState
censusObjectEquiv :: [ClosurePtr] -> DebugM ObjectEquivState
censusObjectEquiv [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 ObjectEquivState)
funcs [ClosurePtr]
cps) (EquivMap -> Equiv2Map -> CensusByObjectEquiv -> ObjectEquivState
ObjectEquivState forall k p v. OrdPSQ k p v
PS.empty forall a. IntMap a
IM.empty forall a. IntMap a
IM.empty)
  where
    funcs :: TraceFunctions (StateT ObjectEquivState)
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr -> StateT ObjectEquivState DebugM ()
papTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ClosurePtr -> StateT ObjectEquivState DebugM ()
stackTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> StateT ObjectEquivState DebugM ()
-> StateT ObjectEquivState DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> StateT ObjectEquivState DebugM ()
-> StateT ObjectEquivState DebugM ()
closAccum
              , visitedVal :: ClosurePtr -> StateT ObjectEquivState DebugM ()
visitedVal = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc -> StateT ObjectEquivState DebugM ()
conDescTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (StateT ObjectEquivState DebugM) ()
               -> (StateT ObjectEquivState DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> StateT ObjectEquivState DebugM ()
-> StateT ObjectEquivState DebugM ()
closAccum ClosurePtr
cp SizedClosure
s StateT ObjectEquivState DebugM ()
k = do
      -- Step 0: Check to see whether there is already an equivalence class
      -- for this cp
      -- Step 1: Decode a bit more of the object, so we can see all the
      -- pointers.
      PtrClosure
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.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM (GenStackFrames ClosurePtr)
dereferenceStack forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      -- Step 2: Replace all the pointers in the closure by things they are
      -- equivalent to we have already seen.
      PtrClosure
s''  <- forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
MonadState ObjectEquivState m =>
ClosurePtr -> m ClosurePtr
rep_c) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
MonadState ObjectEquivState m =>
ClosurePtr -> m ClosurePtr
rep_c) forall {m :: * -> *}.
MonadState ObjectEquivState m =>
ClosurePtr -> m ClosurePtr
rep_c PtrClosure
s'
      -- Step 3: Have we seen a closure like this one before?
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (ClosurePtr -> PtrClosure -> ObjectEquivState -> ObjectEquivState
addEquiv ClosurePtr
cp PtrClosure
s'')

{-
        -- Yes, we have seen something of identical shape
        -- 1. Update equivalence maps to map this closure into the right
        -- equivalence class
        Just new_cp -> do
          n <- checkSize <$> lift get
          traceShowM n
          lift $ modify' (addNewMap cp new_cp)
          return new_cp
          --
        -- No, never seen something like this before
        -- Add the mapping to emap
        Nothing -> do
          lift $ modify' (addNewEquiv cp s'')
          return cp
          -}

      -- Step 4: Update the census, now we know the equivalence class of
      -- the object
      --lift $ modify' (go new_cp s'')
      -- Step 5: Call the continuation to carry on with the analysis
      StateT ObjectEquivState DebugM ()
k

    rep_c :: ClosurePtr -> m ClosurePtr
rep_c cp :: ClosurePtr
cp@(ClosurePtr Word64
k) = do
      Equiv2Map
m <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ObjectEquivState -> Equiv2Map
emap2
      case forall a. Int -> IntMap a -> Maybe a
IM.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k) Equiv2Map
m of
        -- There is an equivalence class already
        Just ClosurePtr
cp' -> forall (m :: * -> *) a. Monad m => a -> m a
return ClosurePtr
cp'
        -- No equivalence class yet
        Maybe ClosurePtr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ClosurePtr
cp

printObjectEquiv :: EquivMap -> IO ()
printObjectEquiv :: EquivMap -> IO ()
printObjectEquiv EquivMap
c = do
  let cmp :: (a, b, c) -> b
cmp (a
_, b
b,c
_) = b
b
      res :: [(PtrClosure, Int, ClosurePtr)]
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 forall {a} {b} {c}. (a, b, c) -> b
cmp)) (forall k p v. OrdPSQ k p v -> [(k, p, v)]
PS.toList EquivMap
c)
      showLine :: (DebugClosureWithSize p ConstrDesc s c, a, a) -> [Char]
showLine (DebugClosureWithSize p ConstrDesc s c
k, a
p, a
v) =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. Show a => a -> [Char]
show a
v, [Char]
":", forall a. Show a => a -> [Char]
show a
p,[Char]
":", forall c p s.
[Char]
-> (Int -> c -> [Char])
-> Int
-> DebugClosure p ConstrDesc s c
-> [Char]
ppClosure [Char]
"" (\Int
_ -> forall a. Show a => a -> [Char]
show) Int
0 (forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize p ConstrDesc s c
k)]
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a} {c} {p} {s}.
(Show a, Show a, Show c) =>
(DebugClosureWithSize p ConstrDesc s c, a, a) -> [Char]
showLine) [(PtrClosure, Int, ClosurePtr)]
res
--  writeFile "profile/profile_out.txt" (unlines $ "key, total, count, max, avg" : (map showLine res))

objectEquivAnalysis :: DebugM (EquivMap, HeapGraph Size)
objectEquivAnalysis :: DebugM (EquivMap, HeapGraph Size)
objectEquivAnalysis = 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)
  EquivMap
r1 <- ObjectEquivState -> EquivMap
emap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ClosurePtr] -> DebugM ObjectEquivState
censusObjectEquiv [ClosurePtr]
rs
  let elems :: EquivMap
elems = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k p v.
(Ord k, Ord p) =>
p -> OrdPSQ k p v -> ([(k, p, v)], OrdPSQ k p v)
PS.atMostView Int
of_interest EquivMap
r1
      cmp :: (a, b, c) -> b
cmp (a
_, b
b,c
_) = b
b
      cps :: [ClosurePtr]
cps = forall a b. (a -> b) -> [a] -> [b]
map (\(PtrClosure
_, Int
_, ClosurePtr
cp) -> ClosurePtr
cp) (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 forall {a} {b} {c}. (a, b, c) -> b
cmp)) (forall k p v. OrdPSQ k p v -> [(k, p, v)]
PS.toList EquivMap
elems))
  -- Use this code if we are returning ClosurePtr not SourceInformation
  HeapGraph Size
r2 <- case [ClosurePtr]
cps of
    [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"None"
    (ClosurePtr
c:[ClosurePtr]
cs) -> Maybe Int -> NonEmpty ClosurePtr -> DebugM (HeapGraph Size)
multiBuildHeapGraph (forall a. a -> Maybe a
Just Int
10) (ClosurePtr
c forall a. a -> [a] -> NonEmpty a
:| [ClosurePtr]
cs)
  return (EquivMap
r1, HeapGraph Size
r2)

objectEquiv :: Debuggee -> IO ()
objectEquiv :: Debuggee -> IO ()
objectEquiv = forall a r. DebugM a -> (a -> IO r) -> Debuggee -> IO r
runAnalysis DebugM (EquivMap, HeapGraph Size)
objectEquivAnalysis forall a b. (a -> b) -> a -> b
$ \(EquivMap
rmap, HeapGraph Size
hg) -> do
                                                    EquivMap -> IO ()
printObjectEquiv EquivMap
rmap
                                                    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. (a -> [Char]) -> HeapGraph a -> [Char]
ppHeapGraph forall a. Show a => a -> [Char]
show HeapGraph Size
hg