{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Functions for analysing memory fragmentation
module GHC.Debug.Fragmentation (summariseBlocks
                                     , censusByMBlock
                                      , printMBlockCensus
                                      , censusByBlock
                                      , printBlockCensus
                                      , censusPinnedBlocks
                                      , PinnedCensusStats(..)

                                      , findBadPtrs
                                      , histogram
                                      ) where

import GHC.Debug.Profile
import GHC.Debug.Client
import GHC.Debug.Types
--import GHC.Debug.Client.Monad

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (nub, sortBy)
import Data.Ord
import Data.Word

-- | Print a summary of the given raw blocks
-- This is useful to see how many MBlocks and how many pinned blocks there
-- are.
summariseBlocks :: [RawBlock] -> IO ()
summariseBlocks :: [RawBlock] -> IO ()
summariseBlocks [RawBlock]
bs = do
  String -> IO ()
putStrLn (String
"TOTAL BLOCKS: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [RawBlock]
bs))
  String -> IO ()
putStrLn (String
"PINNED BLOCKS: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter RawBlock -> Bool
isPinnedBlock [RawBlock]
bs))
  String -> IO ()
putStrLn (String
"MBLOCK: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n_mblocks)
  String -> IO ()
putStrLn (String
"PINNED MBLOCKS: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n_pmblocks)
  where
    n_mblocks :: Int
    n_mblocks :: Int
n_mblocks = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map (BlockPtr -> Word64
blockMBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBlock -> BlockPtr
rawBlockAddr) [RawBlock]
bs))

    n_pmblocks :: Int
n_pmblocks = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map (BlockPtr -> Word64
blockMBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBlock -> BlockPtr
rawBlockAddr) (forall a. (a -> Bool) -> [a] -> [a]
filter RawBlock -> Bool
isPinnedBlock [RawBlock]
bs)))

-- | Perform a heap census by which MBlock each closure lives in
censusByMBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats)
censusByMBlock :: [ClosurePtr] -> DebugM (Map BlockPtr CensusStats)
censusByMBlock = forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy forall {m :: * -> *} {srt} {pap} {string} {s} {b}.
Monad m =>
ClosurePtr
-> DebugClosureWithSize srt pap string s b
-> m (Maybe (BlockPtr, CensusStats))
go
  where
    go :: ClosurePtr
-> DebugClosureWithSize srt pap string s b
-> m (Maybe (BlockPtr, CensusStats))
go ClosurePtr
cp DebugClosureWithSize srt pap string s b
d =
      let s :: Size
          s :: Size
s = forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithSize srt pap string s b
d
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
s

          k :: BlockPtr
          k :: BlockPtr
k = ClosurePtr -> BlockPtr
applyMBlockMask ClosurePtr
cp
      in if ClosurePtr -> Bool
heapAlloced ClosurePtr
cp
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (BlockPtr
k, CensusStats
v)
           -- Ignore static things
           else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing

-- | Perform a census based on which block each closure resides in.
censusByBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats)
censusByBlock :: [ClosurePtr] -> DebugM (Map BlockPtr CensusStats)
censusByBlock = forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy forall {m :: * -> *} {srt} {pap} {string} {s} {b}.
Monad m =>
ClosurePtr
-> DebugClosureWithSize srt pap string s b
-> m (Maybe (BlockPtr, CensusStats))
go
  where
    go :: ClosurePtr
-> DebugClosureWithSize srt pap string s b
-> m (Maybe (BlockPtr, CensusStats))
go ClosurePtr
cp DebugClosureWithSize srt pap string s b
d =
      let s :: Size
          s :: Size
s = forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithSize srt pap string s b
d
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
s

          k :: BlockPtr
k = ClosurePtr -> BlockPtr
applyBlockMask ClosurePtr
cp
      in if ClosurePtr -> Bool
heapAlloced ClosurePtr
cp
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (BlockPtr
k, CensusStats
v)
           -- Ignore static things
           else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

newtype PinnedCensusStats =
          PinnedCensusStats (CensusStats, [(ClosurePtr, SizedClosure)])
          deriving (NonEmpty PinnedCensusStats -> PinnedCensusStats
PinnedCensusStats -> PinnedCensusStats -> PinnedCensusStats
forall b. Integral b => b -> PinnedCensusStats -> PinnedCensusStats
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> PinnedCensusStats -> PinnedCensusStats
$cstimes :: forall b. Integral b => b -> PinnedCensusStats -> PinnedCensusStats
sconcat :: NonEmpty PinnedCensusStats -> PinnedCensusStats
$csconcat :: NonEmpty PinnedCensusStats -> PinnedCensusStats
<> :: PinnedCensusStats -> PinnedCensusStats -> PinnedCensusStats
$c<> :: PinnedCensusStats -> PinnedCensusStats -> PinnedCensusStats
Semigroup)

-- | Only census the given (pinned) blocks
censusPinnedBlocks :: [RawBlock]
                   -> [ClosurePtr]
                   -> DebugM (Map.Map BlockPtr PinnedCensusStats)
censusPinnedBlocks :: [RawBlock]
-> [ClosurePtr] -> DebugM (Map BlockPtr PinnedCensusStats)
censusPinnedBlocks [RawBlock]
bs = forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr
-> SizedClosure -> DebugM (Maybe (BlockPtr, PinnedCensusStats))
go
  where
    pbs :: Set BlockPtr
pbs = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map RawBlock -> BlockPtr
rawBlockAddr (forall a. (a -> Bool) -> [a] -> [a]
filter RawBlock -> Bool
isPinnedBlock [RawBlock]
bs))
    go :: ClosurePtr -> SizedClosure
          -> DebugM (Maybe (BlockPtr, PinnedCensusStats))
    go :: ClosurePtr
-> SizedClosure -> DebugM (Maybe (BlockPtr, PinnedCensusStats))
go ClosurePtr
cp SizedClosure
d =
      let v :: CensusStats
          v :: CensusStats
v = Size -> CensusStats
mkCS (forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize SizedClosure
d)

          bp :: BlockPtr
bp = ClosurePtr -> BlockPtr
applyBlockMask ClosurePtr
cp

      in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if BlockPtr
bp forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BlockPtr
pbs
           then forall a. a -> Maybe a
Just (BlockPtr
bp, (CensusStats, [(ClosurePtr, SizedClosure)]) -> PinnedCensusStats
PinnedCensusStats (CensusStats
v, [(ClosurePtr
cp, SizedClosure
d)]))
           -- Ignore static things
           else forall a. Maybe a
Nothing


-- | Given a pinned block census, find the ARR_WORDS objects which are in the
-- blocks which are < 10 % utilised. The return list is sorted by how many
-- times each distinct ARR_WORDS appears on the heap.
findBadPtrs :: Map.Map k PinnedCensusStats
            -> [((Count, [ClosurePtr]), String)]
findBadPtrs :: forall k.
Map k PinnedCensusStats -> [((Count, [ClosurePtr]), String)]
findBadPtrs Map k PinnedCensusStats
mb_census  =
      let fragged_blocks :: Map k PinnedCensusStats
fragged_blocks = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\(PinnedCensusStats (CS Count
_ (Size Int
s) Max Size
_, [(ClosurePtr, SizedClosure)]
_)) -> 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 Word64
blockMaxSize forall a. Ord a => a -> a -> Bool
<= (Double
0.1 :: Double))  Map k PinnedCensusStats
mb_census
          all_arr_words :: [(String, (Count, [ClosurePtr]))]
          all_arr_words :: [(String, (Count, [ClosurePtr]))]
all_arr_words = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PinnedCensusStats (CensusStats
_, [(ClosurePtr, SizedClosure)]
i)) -> forall a b. (a -> b) -> [a] -> [b]
map (\(ClosurePtr
c,SizedClosure
d) -> (SizedClosure -> String
displayArrWords SizedClosure
d, (Int -> Count
Count Int
1, [ClosurePtr
c]))) [(ClosurePtr, SizedClosure)]
i) (forall k a. Map k a -> [a]
Map.elems Map k PinnedCensusStats
fragged_blocks)
          swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)
          dups :: [((Count, [ClosurePtr]), String)]
dups = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. (b, a) -> (a, b)
swap (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ 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 (forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) [(String, (Count, [ClosurePtr]))]
all_arr_words)))
      in [((Count, [ClosurePtr]), String)]
dups

displayArrWords :: SizedClosure -> String
displayArrWords :: SizedClosure -> String
displayArrWords SizedClosure
d =
    case forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
d of
      ArrWordsClosure { [Word]
arrWords :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
arrWords :: [Word]
arrWords } -> forall a. Show a => a -> String
show ([Word] -> ByteString
arrWordsBS [Word]
arrWords)
      DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
_ -> forall a. HasCallStack => String -> a
error String
"Not ARR_WORDS"

printMBlockCensus, printBlockCensus ::  Map.Map BlockPtr CensusStats -> IO ()
printMBlockCensus :: Map BlockPtr CensusStats -> IO ()
printMBlockCensus = Word64 -> [CensusStats] -> IO ()
histogram Word64
mblockMaxSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems
-- | Print out a block census
printBlockCensus :: Map BlockPtr CensusStats -> IO ()
printBlockCensus = Word64 -> [CensusStats] -> IO ()
histogram Word64
blockMaxSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

-- | Print either a MBlock or Block census as a histogram
histogram :: Word64 -> [CensusStats] -> IO ()
histogram :: Word64 -> [CensusStats] -> IO ()
histogram Word64
maxSize [CensusStats]
m =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a} {a}. (Show a, Show a, Show a) => (a, a, a) -> String
displayLine) (forall {a}. (Ord a, Num a) => a -> [a] -> [(a, a, Int)]
bin Double
0 (forall a b. (a -> b) -> [a] -> [b]
map CensusStats -> Double
calcPercentage (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing CensusStats -> Size
cssize) [CensusStats]
m )))
  where
    calcPercentage :: CensusStats -> Double
calcPercentage (CS Count
_ (Size Int
tot) Max Size
_) =
      ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totforall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxSize) forall a. Num a => a -> a -> a
* Double
100 :: Double)

    displayLine :: (a, a, a) -> String
displayLine (a
l, a
h, a
n) = forall a. Show a => a -> String
show a
l forall a. [a] -> [a] -> [a]
++ String
"%-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
h forall a. [a] -> [a] -> [a]
++ String
"%: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n

    bin :: a -> [a] -> [(a, a, Int)]
bin a
_ [] = []
    bin a
k [a]
xs = case [a]
now of
                 [] -> a -> [a] -> [(a, a, Int)]
bin (a
k forall a. Num a => a -> a -> a
+ a
10) [a]
later
                 [a]
_ -> (a
k, a
kforall a. Num a => a -> a -> a
+a
10, forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
now) forall a. a -> [a] -> [a]
: a -> [a] -> [(a, a, Int)]
bin (a
k forall a. Num a => a -> a -> a
+ a
10) [a]
later
      where
        ([a]
now, [a]
later) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<= a
k forall a. Num a => a -> a -> a
+ a
10)) [a]
xs