diff --git a/ghcide/docs/opentelemetry.md b/ghcide/docs/opentelemetry.md index 81c915a243..49d65d5c2c 100644 --- a/ghcide/docs/opentelemetry.md +++ b/ghcide/docs/opentelemetry.md @@ -19,7 +19,9 @@ Then, you can run `ghcide`, giving it a file to dump eventlog information into. ghcide +RTS -l -ol ghcide.eventlog -RTS ``` -You can also optionally enable reporting detailed memory data with `--ot-memory-profiling` +# Profiling the Shake cache + +The flag `--ot-memory-profiling` profiles the values map repeatedly with 1s pauses in between. ```sh ghcide --ot-memory-profiling +RTS -A4G -l -ol ghcide.eventlog -RTS @@ -27,6 +29,8 @@ ghcide --ot-memory-profiling +RTS -A4G -l -ol ghcide.eventlog -RTS *Note:* This option, while functional, is extremely slow. You will notice this because the memory graph in the output will have datapoints spaced apart by a couple of minutes. The nursery must be big enough (-A1G or larger) or the measurements will self-abort. +Another way to profile the heap is by sending a USR1 signal (`kill -s USR1`) to the process. + ## Viewing with tracy After installing `opentelemetry-extra` and `tracy`, you can view the opentelementry output: diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7d5a9eca5a..787b02dbe5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -406,8 +406,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie let ideState = IdeState{..} IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras - when otProfilingEnabled $ - startTelemetry logger $ state shakeExtras + startTelemetry otProfilingEnabled logger $ state shakeExtras return ideState where diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 698115585a..79973be520 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -13,7 +13,7 @@ import Control.Concurrent.Extra (Var, modifyVar_, newVar, readVar, threadDelay) import Control.Exception (evaluate) import Control.Exception.Safe (catch, SomeException) -import Control.Monad (unless, forM_, forever, (>=>)) +import Control.Monad (void, when, unless, forM_, forever, (>=>)) import Control.Monad.Extra (whenJust) import Control.Seq (r0, seqList, seqTuple2, using) import Data.Dynamic (Dynamic) @@ -28,12 +28,13 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), import Development.IDE.Types.Logger (logInfo, Logger, logDebug) import Development.IDE.Types.Shake (Key (..), Value, Values) import Development.Shake (Action, actionBracket, liftIO) +import Ide.PluginUtils (installSigUsr1Handler) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Language.Haskell.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (addEvent, beginSpan, endSpan, +import OpenTelemetry.Eventlog (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) @@ -71,36 +72,47 @@ otTracedAction key file success act = actionBracket unless (success res) $ setTag sp "error" "1" return res) -startTelemetry :: Logger -> Var Values -> IO () -startTelemetry logger stateRef = do +startTelemetry :: Bool -> Logger -> Var Values -> IO () +startTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached mapCountInstrument <- mkValueObserver "values map count" - _ <- regularly (1 * seconds) $ - withSpan_ "Measure length" $ - readVar stateRef - >>= observe mapCountInstrument . length - - _ <- regularly (1 * seconds) $ do - values <- readVar stateRef - let keys = nub - $ Key GhcSession : Key GhcSessionDeps - : [ k | (_,k) <- HMap.keys values - -- do GhcSessionIO last since it closes over stateRef itself - , k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] - !groupedForSharing <- evaluate (keys `using` seqList r0) - measureMemory logger [groupedForSharing] instrumentFor stateRef - `catch` \(e::SomeException) -> - logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) - return () + installSigUsr1Handler $ do + logInfo logger "SIGUSR1 received: performing memory measurement" + performMeasurement logger stateRef instrumentFor mapCountInstrument + + when allTheTime $ void $ regularly (1 * seconds) $ + performMeasurement logger stateRef instrumentFor mapCountInstrument where seconds = 1000000 regularly :: Int -> IO () -> IO (Async ()) regularly delay act = async $ forever (act >> threadDelay delay) -{-# ANN startTelemetry ("HLint: ignore Use nubOrd" :: String) #-} + +performMeasurement :: + Logger -> + Var (HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)) -> + (Maybe Key -> IO OurValueObserver) -> + Instrument 'Asynchronous a m' -> + IO () +performMeasurement logger stateRef instrumentFor mapCountInstrument = do + withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length + + values <- readVar stateRef + let keys = Key GhcSession + : Key GhcSessionDeps + : [ k | (_,k) <- HMap.keys values + -- do GhcSessionIO last since it closes over stateRef itself + , k /= Key GhcSession + , k /= Key GhcSessionDeps + , k /= Key GhcSessionIO + ] ++ [Key GhcSessionIO] + groupedForSharing <- evaluate (keys `using` seqList r0) + measureMemory logger [groupedForSharing] instrumentFor stateRef + `catch` \(e::SomeException) -> + logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) + type OurValueObserver = Int -> IO () diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index caa0768c0e..48c2c3e0c5 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -18,7 +18,7 @@ module Ide.PluginUtils fullRange, mkLspCommand, mkLspCmdId, - allLspCmdIds,allLspCmdIds') + allLspCmdIds,allLspCmdIds',installSigUsr1Handler) where @@ -35,6 +35,7 @@ import Language.Haskell.LSP.Types.Capabilities #ifdef mingw32_HOST_OS import qualified System.Win32.Process as P (getCurrentProcessId) #else +import System.Posix.Signals import qualified System.Posix.Process as P (getProcessID) #endif import qualified Data.Aeson as J @@ -42,6 +43,7 @@ import qualified Data.Default import qualified Data.Map.Strict as Map import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP +import Control.Monad (void) -- --------------------------------------------------------------------- @@ -246,8 +248,14 @@ getPid :: IO T.Text getPid = T.pack . show <$> getProcessID getProcessID :: IO Int +installSigUsr1Handler :: IO () -> IO () + #ifdef mingw32_HOST_OS getProcessID = fromIntegral <$> P.getCurrentProcessId +installSigUsr1Handler _ = return () + #else getProcessID = fromIntegral <$> P.getProcessID + +installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif