{-# LANGUAGE NumericUnderscores #-}
-- | Logging utilities for reporting heap statistics

module Development.IDE.Main.HeapStats ( withHeapStats ) where

import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Monad
import qualified Data.Text                    as T
import           Data.Word
import           Development.IDE.Types.Logger (Logger, logInfo)
import           GHC.Stats
import           Text.Printf                  (printf)

-- | Interval at which to report the latest heap statistics.

heapStatsInterval :: Int
heapStatsInterval :: Int
heapStatsInterval = Int
60_000_000 -- 60s


-- | Report the live bytes and heap size at the last major collection.

logHeapStats :: Logger -> IO ()
logHeapStats :: Logger -> IO ()
logHeapStats Logger
l = do
  RTSStats
stats <- IO RTSStats
getRTSStats
  -- live_bytes is the total amount of live memory in a program

  -- (corresponding to the amount on a heap profile)

  let live_bytes :: Word64
live_bytes = GCDetails -> Word64
gcdetails_live_bytes (RTSStats -> GCDetails
gc RTSStats
stats)
  -- heap_size is the total amount of memory the RTS is using

  -- this corresponds closer to OS memory usage

      heap_size :: Word64
heap_size  = GCDetails -> Word64
gcdetails_mem_in_use_bytes (RTSStats -> GCDetails
gc RTSStats
stats)
      format :: Word64 -> T.Text
      format :: Word64 -> Text
format Word64
m = String -> Text
T.pack (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2fMB" (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 @Double Word64
m Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6))
      message :: Text
message = Text
"Live bytes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
format Word64
live_bytes  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                Text
"Heap size: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
format Word64
heap_size
  Logger -> Text -> IO ()
logInfo Logger
l Text
message

-- | An action which logs heap statistics at the 'heapStatsInterval'

heapStatsThread :: Logger -> IO r
heapStatsThread :: Logger -> IO r
heapStatsThread Logger
l = IO () -> IO r
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO r) -> IO () -> IO r
forall a b. (a -> b) -> a -> b
$ do
  Int -> IO ()
threadDelay Int
heapStatsInterval
  Logger -> IO ()
logHeapStats Logger
l

-- | A helper function which lauches the 'heapStatsThread' and kills it

-- appropiately when the inner action finishes. It also checks to see

-- if `-T` is enabled.

withHeapStats :: Logger -> IO r -> IO r
withHeapStats :: Logger -> IO r -> IO r
withHeapStats Logger
l IO r
k = do
  Bool
enabled <- IO Bool
getRTSStatsEnabled
  if Bool
enabled
    then do
      Logger -> Text -> IO ()
logInfo Logger
l (Text
"Logging heap statistics every "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2fs" (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Double Int
heapStatsInterval Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)))
      IO Any -> (Async Any -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Logger -> IO Any
forall r. Logger -> IO r
heapStatsThread Logger
l) (IO r -> Async Any -> IO r
forall a b. a -> b -> a
const IO r
k)
    else do
      Logger -> Text -> IO ()
logInfo Logger
l Text
"Heap statistics are not enabled (RTS option -T is needed)"
      IO r
k