Perform memory measurement on SIGUSR1

ghcide/docs/opentelemetry.md

@@ -19,14 +19,18 @@ 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
 ```
 
 *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:

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

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 ()
 

hls-plugin-api/src/Ide/PluginUtils.hs

@@ -18,7 +18,7 @@ module Ide.PluginUtils
     fullRange,
     mkLspCommand,
     mkLspCmdId,
-  allLspCmdIds,allLspCmdIds')
+  allLspCmdIds,allLspCmdIds',installSigUsr1Handler)
 where
 
 
@@ -35,13 +35,15 @@ 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
 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