{-# LANGUAGE CPP             #-}
{-# LANGUAGE PackageImports  #-}
{-# LANGUAGE PatternSynonyms #-}
{-# HLINT ignore #-}
module Development.IDE.Core.Tracing
    ( otTracedHandler
    , otTracedAction
    , startProfilingTelemetry
    , measureMemory
    , getInstrumentCached
    , otTracedProvider
    , otSetUri
    , otTracedGarbageCollection
    , withTrace
    , withEventTrace
    , withTelemetryLogger
    )
where

import           Control.Concurrent.Async          (Async, async)
import           Control.Concurrent.Extra          (modifyVar_, newVar, readVar,
                                                    threadDelay)
import           Control.Exception                 (evaluate)
import           Control.Exception.Safe            (SomeException, catch,
                                                    generalBracket)
import           Control.Monad                     (forM_, forever, void, when,
                                                    (>=>))
import           Control.Monad.Catch               (ExitCase (..), MonadMask)
import           Control.Monad.Extra               (whenJust)
import           Control.Monad.IO.Unlift
import           Control.Monad.STM                 (atomically)
import           Control.Seq                       (r0, seqList, seqTuple2,
                                                    using)
import           Data.ByteString                   (ByteString)
import           Data.ByteString.Char8             (pack)
import qualified Data.HashMap.Strict               as HMap
import           Data.IORef                        (modifyIORef', newIORef,
                                                    readIORef, writeIORef)
import           Data.String                       (IsString (fromString))
import qualified Data.Text                         as T
import           Data.Text.Encoding                (encodeUtf8)
import           Data.Typeable                     (TypeRep, typeOf)
import           Data.Word                         (Word16)
import           Debug.Trace.Flags                 (userTracingEnabled)
import           Development.IDE.Core.RuleTypes    (GhcSession (GhcSession),
                                                    GhcSessionDeps (GhcSessionDeps),
                                                    GhcSessionIO (GhcSessionIO))
import           Development.IDE.Graph             (Action)
import           Development.IDE.Graph.Rule
import           Development.IDE.Types.Diagnostics (FileDiagnostic,
                                                    showDiagnostics)
import           Development.IDE.Types.Location    (Uri (..))
import           Development.IDE.Types.Logger      (Logger (Logger), logDebug,
                                                    logInfo)
import           Development.IDE.Types.Shake       (ValueWithDiagnostics (..),
                                                    Values, fromKeyType)
import           Foreign.Storable                  (Storable (sizeOf))
import           HeapSize                          (recursiveSize, runHeapsize)
import           Ide.PluginUtils                   (installSigUsr1Handler)
import           Ide.Types                         (PluginId (..))
import           Language.LSP.Types                (NormalizedFilePath,
                                                    fromNormalizedFilePath)
import qualified "list-t" ListT
import           Numeric.Natural                   (Natural)
import           OpenTelemetry.Eventlog            (SpanInFlight (..), addEvent,
                                                    beginSpan, endSpan,
                                                    mkValueObserver, observe,
                                                    setTag, withSpan, withSpan_)
import qualified StmContainers.Map                 as STM

#if MIN_VERSION_ghc(8,8,0)
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
#else
otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a]
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
#endif

withTrace :: (MonadMask m, MonadIO m) =>
    String -> ((String -> String -> m ()) -> m a) -> m a
withTrace :: String -> ((String -> String -> m ()) -> m a) -> m a
withTrace String
name (String -> String -> m ()) -> m a
act
  | Bool
userTracingEnabled
  = ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) ((SpanInFlight -> m a) -> m a) -> (SpanInFlight -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
      let setSpan' :: String -> String -> m ()
setSpan' String
k String
v = SpanInFlight -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp (String -> ByteString
forall a. IsString a => String -> a
fromString String
k) (String -> ByteString
forall a. IsString a => String -> a
fromString String
v)
      (String -> String -> m ()) -> m a
act String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
setSpan'
  | Bool
otherwise = (String -> String -> m ()) -> m a
act (\String
_ String
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

withEventTrace :: String -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace String
name (ByteString -> m ()) -> m a
act
  | Bool
userTracingEnabled
  = ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) ((SpanInFlight -> m a) -> m a) -> (SpanInFlight -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
      (ByteString -> m ()) -> m a
act (SpanInFlight -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"")
  | Bool
otherwise = (ByteString -> m ()) -> m a
act (\ByteString
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Returns a logger that produces telemetry events in a single span
withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a
withTelemetryLogger :: (Logger -> m a) -> m a
withTelemetryLogger Logger -> m a
k = ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Logger" ((SpanInFlight -> m a) -> m a) -> (SpanInFlight -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp ->
    -- Tracy doesn't like when we create a new span for every log line.
    -- To workaround that, we create a single span for all log events.
    -- This is fine since we don't care about the span itself, only about the events
    Logger -> m a
k (Logger -> m a) -> Logger -> m a
forall a b. (a -> b) -> a -> b
$ (Priority -> Text -> IO ()) -> Logger
Logger ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m ->
            SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Priority -> String
forall a. Show a => a -> String
show Priority
p) (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
trim Text
m)
    where
        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
        trim :: Text -> Text
trim = Int -> Text -> Text
T.take (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Word16
forall a. Bounded a => a
maxBound :: Word16) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)

-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
otTracedHandler
    :: MonadUnliftIO m
    => String -- ^ Message type
    -> String -- ^ Message label
    -> (SpanInFlight -> m a)
    -> m a
otTracedHandler :: String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
requestType String
label SpanInFlight -> m a
act
  | Bool
userTracingEnabled = do
    let !name :: String
name =
            if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
label
            then String
requestType
            else String
requestType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
label
    -- Add an event so all requests can be quickly seen in the viewer without searching
    m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) (\SpanInFlight
sp -> SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" received") IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a -> IO a
runInIO (SpanInFlight -> m a
act SpanInFlight
sp))
  | Bool
otherwise = SpanInFlight -> m a
act (ProcessLocalSpanSerialNumber -> SpanInFlight
SpanInFlight ProcessLocalSpanSerialNumber
0)

otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (Uri Text
t) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"uri" (Text -> ByteString
encodeUtf8 Text
t)

-- | Trace a Shake action using opentelemetry.
otTracedAction
    :: Show k
    => k -- ^ The Action's Key
    -> NormalizedFilePath -- ^ Path to the file the action was run for
    -> RunMode
    -> (a -> String)
    -> (([FileDiagnostic] -> Action ()) -> Action (RunResult a)) -- ^ The action
    -> Action (RunResult a)
otTracedAction :: k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode a -> String
result ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act
  | Bool
userTracingEnabled = (RunResult a, ()) -> RunResult a
forall a b. (a, b) -> a
fst ((RunResult a, ()) -> RunResult a)
-> Action (RunResult a, ()) -> Action (RunResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Action SpanInFlight
-> (SpanInFlight -> ExitCase (RunResult a) -> Action ())
-> (SpanInFlight -> Action (RunResult a))
-> Action (RunResult a, ())
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
        (do
            SpanInFlight
sp <- ByteString -> Action SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan (String -> ByteString
forall a. IsString a => String -> a
fromString (k -> String
forall a. Show a => a -> String
show k
key))
            SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"File" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
            SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"Mode" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ RunMode -> String
forall a. Show a => a -> String
show RunMode
mode)
            SpanInFlight -> Action SpanInFlight
forall (m :: * -> *) a. Monad m => a -> m a
return SpanInFlight
sp
        )
        (\SpanInFlight
sp ExitCase (RunResult a)
ec -> do
          case ExitCase (RunResult a)
ec of
            ExitCase (RunResult a)
ExitCaseAbort -> SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
            ExitCaseException SomeException
e -> SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
            ExitCaseSuccess RunResult a
res -> do
                SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"result" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> String
result (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ RunResult a -> a
forall value. RunResult value -> value
runValue RunResult a
res)
                SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"changed" (ByteString -> Action ()) -> ByteString -> Action ()
forall a b. (a -> b) -> a -> b
$ case RunResult a
res of
                    RunResult RunChanged
x ByteString
_ a
_ -> String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ RunChanged -> String
forall a. Show a => a -> String
show RunChanged
x
          SpanInFlight -> Action ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
        (\SpanInFlight
sp -> ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ())
-> ([FileDiagnostic] -> IO ()) -> [FileDiagnostic] -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"diagnostics" (ByteString -> IO ())
-> ([FileDiagnostic] -> ByteString) -> [FileDiagnostic] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> ([FileDiagnostic] -> Text) -> [FileDiagnostic] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Text
showDiagnostics ))
  | Bool
otherwise = ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (\[FileDiagnostic]
_ -> () -> Action ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

otTracedGarbageCollection :: ByteString -> f [a] -> f [a]
otTracedGarbageCollection ByteString
label f [a]
act
  | Bool
userTracingEnabled = ([a], ()) -> [a]
forall a b. (a, b) -> a
fst (([a], ()) -> [a]) -> f ([a], ()) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      f SpanInFlight
-> (SpanInFlight -> ExitCase [a] -> f ())
-> (SpanInFlight -> f [a])
-> f ([a], ())
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
        (ByteString -> f SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan ByteString
label)
        (\SpanInFlight
sp ExitCase [a]
ec -> do
            case ExitCase [a]
ec of
                ExitCase [a]
ExitCaseAbort -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
                ExitCaseException SomeException
e -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                ExitCaseSuccess [a]
res -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"keys" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
res)
            SpanInFlight -> f ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
        (f [a] -> SpanInFlight -> f [a]
forall a b. a -> b -> a
const f [a]
act)
  | Bool
otherwise = f [a]
act

otTracedProvider :: PluginId -> ByteString -> m a -> m a
otTracedProvider (PluginId Text
pluginName) ByteString
provider m a
act
  | Bool
userTracingEnabled = do
    m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
provider ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" provider") ((SpanInFlight -> IO a) -> IO a) -> (SpanInFlight -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
        SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"plugin" (Text -> ByteString
encodeUtf8 Text
pluginName)
        m a -> IO a
runInIO m a
act
  | Bool
otherwise = m a
act


startProfilingTelemetry :: Bool -> Logger -> Values -> IO ()
startProfilingTelemetry :: Bool -> Logger -> Values -> IO ()
startProfilingTelemetry Bool
allTheTime Logger
logger Values
state = do
    Maybe String -> IO OurValueObserver
instrumentFor <- IO (Maybe String -> IO OurValueObserver)
getInstrumentCached

    IO () -> IO ()
installSigUsr1Handler (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Logger -> Text -> IO ()
logInfo Logger
logger Text
"SIGUSR1 received: performing memory measurement"
        Logger -> Values -> (Maybe String -> IO OurValueObserver) -> IO ()
performMeasurement Logger
logger Values
state Maybe String -> IO OurValueObserver
instrumentFor

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
allTheTime (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO (Async ())
regularly (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
seconds) (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
        Logger -> Values -> (Maybe String -> IO OurValueObserver) -> IO ()
performMeasurement Logger
logger Values
state Maybe String -> IO OurValueObserver
instrumentFor
  where
        seconds :: Int
seconds = Int
1000000

        regularly :: Int -> IO () -> IO (Async ())
        regularly :: Int -> IO () -> IO (Async ())
regularly Int
delay IO ()
act = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
act IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OurValueObserver
threadDelay Int
delay)


performMeasurement ::
  Logger ->
  Values ->
  (Maybe String -> IO OurValueObserver) ->
  IO ()
performMeasurement :: Logger -> Values -> (Maybe String -> IO OurValueObserver) -> IO ()
performMeasurement Logger
logger Values
values Maybe String -> IO OurValueObserver
instrumentFor = do
    [(Key, ValueWithDiagnostics)]
contents <- STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a. STM a -> IO a
atomically (STM [(Key, ValueWithDiagnostics)]
 -> IO [(Key, ValueWithDiagnostics)])
-> STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Key, ValueWithDiagnostics)
 -> STM [(Key, ValueWithDiagnostics)])
-> ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ Values -> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT Values
values
    let keys :: [TypeRep]
keys = GhcSession -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSession
GhcSession
             TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: GhcSessionDeps -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionDeps
GhcSessionDeps
             -- TODO restore
             TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [ TypeRep
kty
                | (Key
k,ValueWithDiagnostics
_) <- [(Key, ValueWithDiagnostics)]
contents
                , Just (TypeRep
kty,NormalizedFilePath
_) <- [Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType Key
k]
                -- do GhcSessionIO last since it closes over stateRef itself
                , TypeRep
kty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSession -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSession
GhcSession
                , TypeRep
kty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionDeps -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionDeps
GhcSessionDeps
                , TypeRep
kty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO
             ]
             [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++ [GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO]
    [TypeRep]
groupedForSharing <- [TypeRep] -> IO [TypeRep]
forall a. a -> IO a
evaluate ([TypeRep]
keys [TypeRep] -> Strategy [TypeRep] -> [TypeRep]
forall a. a -> Strategy a -> a
`using` Strategy TypeRep -> Strategy [TypeRep]
forall a. Strategy a -> Strategy [a]
seqList Strategy TypeRep
forall a. Strategy a
r0)
    Logger
-> [[TypeRep]]
-> (Maybe String -> IO OurValueObserver)
-> Values
-> IO ()
measureMemory Logger
logger [[TypeRep]
groupedForSharing] Maybe String -> IO OurValueObserver
instrumentFor Values
values
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e::SomeException) ->
        Logger -> Text -> IO ()
logInfo Logger
logger (Text
"MEMORY PROFILING ERROR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))


type OurValueObserver = Int -> IO ()

getInstrumentCached :: IO (Maybe String -> IO OurValueObserver)
getInstrumentCached :: IO (Maybe String -> IO OurValueObserver)
getInstrumentCached = do
    Var (HashMap String ValueObserver)
instrumentMap <- HashMap String ValueObserver
-> IO (Var (HashMap String ValueObserver))
forall a. a -> IO (Var a)
newVar HashMap String ValueObserver
forall k v. HashMap k v
HMap.empty
    ValueObserver
mapBytesInstrument <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"value map size_bytes"

    let instrumentFor :: String -> IO (Int -> m ())
instrumentFor String
k = do
          Maybe ValueObserver
mb_inst <- String -> HashMap String ValueObserver -> Maybe ValueObserver
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup String
k (HashMap String ValueObserver -> Maybe ValueObserver)
-> IO (HashMap String ValueObserver) -> IO (Maybe ValueObserver)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var (HashMap String ValueObserver)
-> IO (HashMap String ValueObserver)
forall a. Var a -> IO a
readVar Var (HashMap String ValueObserver)
instrumentMap
          case Maybe ValueObserver
mb_inst of
            Maybe ValueObserver
Nothing -> do
                ValueObserver
instrument <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> String
forall a. Show a => a -> String
show String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" size_bytes"))
                Var (HashMap String ValueObserver)
-> (HashMap String ValueObserver
    -> IO (HashMap String ValueObserver))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap String ValueObserver)
instrumentMap (HashMap String ValueObserver -> IO (HashMap String ValueObserver)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap String ValueObserver -> IO (HashMap String ValueObserver))
-> (HashMap String ValueObserver -> HashMap String ValueObserver)
-> HashMap String ValueObserver
-> IO (HashMap String ValueObserver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> ValueObserver
-> HashMap String ValueObserver
-> HashMap String ValueObserver
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert String
k ValueObserver
instrument)
                (Int -> m ()) -> IO (Int -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> m ()) -> IO (Int -> m ()))
-> (Int -> m ()) -> IO (Int -> m ())
forall a b. (a -> b) -> a -> b
$ ValueObserver -> Int -> m ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
instrument
            Just ValueObserver
v -> (Int -> m ()) -> IO (Int -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> m ()) -> IO (Int -> m ()))
-> (Int -> m ()) -> IO (Int -> m ())
forall a b. (a -> b) -> a -> b
$ ValueObserver -> Int -> m ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
v
    (Maybe String -> IO OurValueObserver)
-> IO (Maybe String -> IO OurValueObserver)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe String -> IO OurValueObserver)
 -> IO (Maybe String -> IO OurValueObserver))
-> (Maybe String -> IO OurValueObserver)
-> IO (Maybe String -> IO OurValueObserver)
forall a b. (a -> b) -> a -> b
$ IO OurValueObserver
-> (String -> IO OurValueObserver)
-> Maybe String
-> IO OurValueObserver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OurValueObserver -> IO OurValueObserver
forall (m :: * -> *) a. Monad m => a -> m a
return (OurValueObserver -> IO OurValueObserver)
-> OurValueObserver -> IO OurValueObserver
forall a b. (a -> b) -> a -> b
$ ValueObserver -> OurValueObserver
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
mapBytesInstrument) String -> IO OurValueObserver
forall (m :: * -> *). MonadIO m => String -> IO (Int -> m ())
instrumentFor

whenNothing :: IO () -> IO (Maybe a) -> IO ()
whenNothing :: IO () -> IO (Maybe a) -> IO ()
whenNothing IO ()
act IO (Maybe a)
mb = IO (Maybe a)
mb IO (Maybe a) -> (Maybe a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> IO ()
forall a. Maybe a -> IO ()
f
  where f :: Maybe a -> IO ()
f Maybe a
Nothing = IO ()
act
        f Just{}  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

measureMemory
    :: Logger
    -> [[TypeRep]]     -- ^ Grouping of keys for the sharing-aware analysis
    -> (Maybe String -> IO OurValueObserver)
    -> Values
    -> IO ()
measureMemory :: Logger
-> [[TypeRep]]
-> (Maybe String -> IO OurValueObserver)
-> Values
-> IO ()
measureMemory Logger
logger [[TypeRep]]
groups Maybe String -> IO OurValueObserver
instrumentFor Values
values = ByteString -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> m a -> m a
withSpan_ ByteString
"Measure Memory" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [(Key, ValueWithDiagnostics)]
contents <- STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a. STM a -> IO a
atomically (STM [(Key, ValueWithDiagnostics)]
 -> IO [(Key, ValueWithDiagnostics)])
-> STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Key, ValueWithDiagnostics)
 -> STM [(Key, ValueWithDiagnostics)])
-> ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ Values -> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT Values
values
    IORef (Maybe Int)
valuesSizeRef <- Maybe Int -> IO (IORef (Maybe Int))
forall a. a -> IO (IORef a)
newIORef (Maybe Int -> IO (IORef (Maybe Int)))
-> Maybe Int -> IO (IORef (Maybe Int))
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
    let !groupsOfGroupedValues :: [[(String, [Value Dynamic])]]
groupsOfGroupedValues = [(Key, ValueWithDiagnostics)] -> [[(String, [Value Dynamic])]]
groupValues [(Key, ValueWithDiagnostics)]
contents
    Logger -> Text -> IO ()
logDebug Logger
logger Text
"STARTING MEMORY PROFILING"
    [[(String, [Value Dynamic])]]
-> ([(String, [Value Dynamic])] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[(String, [Value Dynamic])]]
groupsOfGroupedValues (([(String, [Value Dynamic])] -> IO ()) -> IO ())
-> ([(String, [Value Dynamic])] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(String, [Value Dynamic])]
groupedValues -> do
        Maybe Int
keepGoing <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
valuesSizeRef
        Maybe Int -> OurValueObserver -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
keepGoing (OurValueObserver -> IO ()) -> OurValueObserver -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
          IO () -> IO (Maybe ()) -> IO ()
forall a. IO () -> IO (Maybe a) -> IO ()
whenNothing (IORef (Maybe Int) -> Maybe Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
valuesSizeRef Maybe Int
forall a. Maybe a
Nothing) (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          Natural -> IO (Maybe ()) -> IO (Maybe ())
forall (m :: * -> *) a.
Monad m =>
Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust Natural
3 (IO (Maybe ()) -> IO (Maybe ())) -> IO (Maybe ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
          -- logDebug logger (fromString $ show $ map fst groupedValues)
          Int -> Heapsize () -> IO (Maybe ())
forall a. Int -> Heapsize a -> IO (Maybe a)
runHeapsize Int
25000000 (Heapsize () -> IO (Maybe ())) -> Heapsize () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
              [(String, [Value Dynamic])]
-> ((String, [Value Dynamic]) -> Heapsize ()) -> Heapsize ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [Value Dynamic])]
groupedValues (((String, [Value Dynamic]) -> Heapsize ()) -> Heapsize ())
-> ((String, [Value Dynamic]) -> Heapsize ()) -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ \(String
k,[Value Dynamic]
v) -> ByteString -> (SpanInFlight -> Heapsize ()) -> Heapsize ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
"Measure " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a. IsString a => String -> a
fromString String
k) ((SpanInFlight -> Heapsize ()) -> Heapsize ())
-> (SpanInFlight -> Heapsize ()) -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
              IORef Int
acc <- IO (IORef Int) -> Heapsize (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> Heapsize (IORef Int))
-> IO (IORef Int) -> Heapsize (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
              OurValueObserver
observe <- IO OurValueObserver -> Heapsize OurValueObserver
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OurValueObserver -> Heapsize OurValueObserver)
-> IO OurValueObserver -> Heapsize OurValueObserver
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO OurValueObserver
instrumentFor (Maybe String -> IO OurValueObserver)
-> Maybe String -> IO OurValueObserver
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
k
              (Value Dynamic -> Heapsize ()) -> [Value Dynamic] -> Heapsize ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value Dynamic -> Heapsize Int
forall a. a -> Heapsize Int
recursiveSize (Value Dynamic -> Heapsize Int)
-> (Int -> Heapsize ()) -> Value Dynamic -> Heapsize ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \Int
x -> IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
acc (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x))) [Value Dynamic]
v
              Int
size <- IO Int -> Heapsize Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Heapsize Int) -> IO Int -> Heapsize Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
acc
              let !byteSize :: Int
byteSize = Word -> Int
forall a. Storable a => a -> Int
sizeOf (Word
forall a. HasCallStack => a
undefined :: Word) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
size
              SpanInFlight -> ByteString -> ByteString -> Heapsize ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"size" (String -> ByteString
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
byteSize String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes"))
              () <- IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Heapsize ()) -> IO () -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ OurValueObserver
observe Int
byteSize
              IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Heapsize ()) -> IO () -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Int) -> (Maybe Int -> Maybe Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Maybe Int)
valuesSizeRef ((Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
byteSize))

    Maybe Int
mbValuesSize <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
valuesSizeRef
    case Maybe Int
mbValuesSize of
        Just Int
valuesSize -> do
            OurValueObserver
observe <- Maybe String -> IO OurValueObserver
instrumentFor Maybe String
forall a. Maybe a
Nothing
            OurValueObserver
observe Int
valuesSize
            Logger -> Text -> IO ()
logDebug Logger
logger Text
"MEMORY PROFILING COMPLETED"
        Maybe Int
Nothing ->
            Logger -> Text -> IO ()
logInfo Logger
logger Text
"Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"

    where
        -- groupValues :: Values -> [ [(String, [Value Dynamic])] ]
        groupValues :: [(Key, ValueWithDiagnostics)] -> [[(String, [Value Dynamic])]]
groupValues [(Key, ValueWithDiagnostics)]
contents =
            let !groupedValues :: [[(String, [Value Dynamic])]]
groupedValues =
                    [ [ (TypeRep -> String
forall a. Show a => a -> String
show TypeRep
ty, [Value Dynamic]
vv)
                      | TypeRep
ty <- [TypeRep]
groupKeys
                      , let vv :: [Value Dynamic]
vv = [ Value Dynamic
v | (Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType -> Just (TypeRep
kty,NormalizedFilePath
_), ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
_) <- [(Key, ValueWithDiagnostics)]
contents
                                     , TypeRep
kty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
ty]
                      ]
                    | [TypeRep]
groupKeys <- [[TypeRep]]
groups
                    ]
                -- force the spine of the nested lists
            in [[(String, [Value Dynamic])]]
groupedValues [[(String, [Value Dynamic])]]
-> Strategy [[(String, [Value Dynamic])]]
-> [[(String, [Value Dynamic])]]
forall a. a -> Strategy a -> a
`using` Strategy [(String, [Value Dynamic])]
-> Strategy [[(String, [Value Dynamic])]]
forall a. Strategy a -> Strategy [a]
seqList (Strategy (String, [Value Dynamic])
-> Strategy [(String, [Value Dynamic])]
forall a. Strategy a -> Strategy [a]
seqList (Strategy String
-> Strategy [Value Dynamic] -> Strategy (String, [Value Dynamic])
forall a b. Strategy a -> Strategy b -> Strategy (a, b)
seqTuple2 Strategy String
forall a. Strategy a
r0 (Strategy (Value Dynamic) -> Strategy [Value Dynamic]
forall a. Strategy a -> Strategy [a]
seqList Strategy (Value Dynamic)
forall a. Strategy a
r0)))

repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust :: Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust Natural
0 m (Maybe a)
_ = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
repeatUntilJust Natural
nattempts m (Maybe a)
action = do
    Maybe a
res <- m (Maybe a)
action
    case Maybe a
res of
        Maybe a
Nothing -> Natural -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust (Natural
nattemptsNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1) m (Maybe a)
action
        Just{}  -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res