Collect metrics and expose an EKG server

cabal-ghc901.project

@@ -53,6 +53,12 @@ source-repository-package
   subdir: dependent-sum-template
 -- https://github.com/obsidiansystems/dependent-sum/pull/59
 
+source-repository-package
+  type:git
+  location: https://github.com/tvh/ekg-wai/
+  tag: ba56333e0959f896a03f15a9f151f4a31d1bfcca
+  -- https://github.com/tvh/ekg-wai/issues/4
+
 write-ghc-environment-files: never
 
 index-state: 2021-10-04T02:41:06Z
@@ -62,6 +68,14 @@ constraints:
     haskell-language-server -brittany -class -stylishhaskell -tactic
 
 allow-newer:
+    -- https://github.com/tibbe/ekg/issues/85
+    ekg:base,
+    ekg-core:base,
+    ekg-core:ghc-prim,
+    ekg-json:base,
+    -- https://github.com/tvh/ekg-wai/issues/6
+    ekg-wai:base,
+    snap-server:base,
     floskell:base,
     floskell:ghc-prim,
     -- for shake-bench

cabal-ghc921.project

@@ -49,6 +49,12 @@ source-repository-package
   tag: 224f3901eaa1b32a27e097968afd4a3894efa77e
   -- https://github.com/pepeiborra/ghc-check/pull/14/files
 
+source-repository-package
+  type:git
+  location: https://github.com/tvh/ekg-wai/
+  tag: ba56333e0959f896a03f15a9f151f4a31d1bfcca
+  -- https://github.com/tvh/ekg-wai/issues/4
+
 write-ghc-environment-files: never
 
 index-state: 2021-09-29T21:38:47Z
@@ -78,7 +84,12 @@ allow-newer:
   dependent-sum:constraints,
   diagrams:diagrams-core,
   Chart-diagrams:diagrams-core,
-  SVGFonts:diagrams-core
+  SVGFonts:diagrams-core,
+  ekg:base,
+  ekg-core:base,
+  ekg-core:ghc-prim,
+  ekg-json:base,
+  ekg-wai:base
 
 constraints:
   Agda ==2.6.1.3,

cabal.project

@@ -43,7 +43,14 @@ index-state: 2021-10-04T02:41:06Z
 constraints:
     hyphenation +embed
 
+source-repository-package
+  type:git
+  location: https://github.com/tvh/ekg-wai/
+  tag: ba56333e0959f896a03f15a9f151f4a31d1bfcca
+  -- https://github.com/tvh/ekg-wai/issues/4
+
 allow-newer:
+    ekg-wai:base,
     -- for shake-bench
     Chart-diagrams:diagrams-core,
     SVGFonts:diagrams-core

docs/contributing/contributing.md

@@ -193,6 +193,35 @@ If you don't want to use [nix](https://nixos.org/guides/install-nix.html), you c
 
 See the [tutorial](./plugin-tutorial.md) on writing a plugin in HLS.
 
+## Measuring, benchmarking and tracing
+
+### Metrics
+
+HLS opens a metrics server on port 8000 exposing GC and ghcide metrics. The ghcide metrics currently exposed are:
+
+- `ghcide.values_count`- count of build results in the store
+- `ghcide.database_count` - count of build keys in the store (these two would be the same in the absence of GC)
+- `ghcide.build_count` - build count. A key is GC'ed if it is dirty and older than 100 builds
+- `ghcide.dirty_keys_count` - non transitive count of dirty build keys
+- `ghcide.indexing_pending_count` - count of items in the indexing queue
+- `ghcide.exports_map_count` - count of identifiers in the exports map.
+
+### Benchmarks
+
+If you are touching performance sensitive code, take the time to run a differential
+benchmark between HEAD and master using the benchHist script. This assumes that
+"master" points to the upstream master.
+
+Run the benchmarks with `cabal bench ghcide`.
+
+It should take around 25 minutes and the results will be stored in the `ghcide/bench-results` folder. To interpret the results, see the comments in the `ghcide/bench/hist/Main.hs` module.
+
+More details in [bench/README](../../ghcide/bench/README.md)
+
+### Tracing
+
+HLS records opentelemetry eventlog traces via [opentelemetry](https://hackage.haskell.org/package/opentelemetry). To generate the traces, build with `-eventlog` and run with `+RTS -l`. To visualize the traces, install [Tracy](https://github.com/wolfpld/tracy) and use [eventlog-to-tracy](https://hackage.haskell.org/package/opentelemetry-extra) to open the generated eventlog.
+
 ## Adding support for a new editor
 
 Adding support for new editors is fairly easy if the editor already has good support for generic LSP-based extensions.

ghcide/ghcide.cabal

@@ -48,6 +48,8 @@ library
         dependent-map,
         dependent-sum,
         dlist,
+        ekg-wai,
+        ekg-core,
         exceptions,
         -- we can't use >= 1.7.10 while we have to use hlint == 3.2.*
         extra >= 1.7.4 && < 1.7.10,

ghcide/src/Development/IDE/Core/Service.hs

@@ -30,8 +30,8 @@ import qualified Language.LSP.Types              as LSP
 
 import           Control.Monad
 import           Development.IDE.Core.Shake
-import           System.Environment             (lookupEnv)
-
+import           System.Environment              (lookupEnv)
+import           System.Metrics
 
 ------------------------------------------------------------
 -- Exposed API
@@ -46,8 +46,9 @@ initialise :: Config
            -> VFSHandle
            -> HieDb
            -> IndexQueue
+           -> Maybe Store
            -> IO IdeState
-initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = do
+initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan metrics = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -64,6 +65,7 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hied
         hiedbChan
         vfs
         (optShakeOptions options)
+        metrics
           $ do
             addIdeGlobal $ GlobalIdeOptions options
             ofInterestRules

ghcide/src/Development/IDE/Core/Shake.hs

@@ -120,6 +120,7 @@ import           Development.IDE.Graph                  hiding (ShakeValue)
 import qualified Development.IDE.Graph                  as Shake
 import           Development.IDE.Graph.Database         (ShakeDatabase,
                                                          shakeGetBuildStep,
+                                                         shakeGetDatabaseKeys,
                                                          shakeOpenDatabase,
                                                          shakeProfileDatabase,
                                                          shakeRunDatabaseForKeys)
@@ -152,7 +153,7 @@ import           Data.Aeson                             (toJSON)
 import qualified Data.ByteString.Char8                  as BS8
 import           Data.Coerce                            (coerce)
 import           Data.Default
-import           Data.Foldable                          (toList)
+import           Data.Foldable                          (for_, toList)
 import           Data.HashSet                           (HashSet)
 import qualified Data.HashSet                           as HSet
 import           Data.IORef.Extra                       (atomicModifyIORef'_,
@@ -165,6 +166,8 @@ import           HieDb.Types
 import           Ide.Plugin.Config
 import qualified Ide.PluginUtils                        as HLS
 import           Ide.Types                              (PluginId)
+import           System.Metrics                         (Store, registerCounter,
+                                                         registerGauge)
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -328,7 +331,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           | otherwise = do
           pmap <- readVar persistentKeys
           mv <- runMaybeT $ do
-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k
+            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
             f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
@@ -491,10 +494,11 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
           -> IndexQueue
           -> VFSHandle
           -> ShakeOptions
+          -> Maybe Store
           -> Rules ()
           -> IO IdeState
 shakeOpen lspEnv defaultConfig logger debouncer
-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo
+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts metrics rules = mdo
 
     us <- mkSplitUniqSupply 'r'
     ideNc <- newIORef (initNameCache us knownKeyNames)
@@ -543,11 +547,28 @@ shakeOpen lspEnv defaultConfig logger debouncer
     IdeOptions
         { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled
         , optProgressStyle
+        , optCheckParents
         } <- getIdeOptionsIO shakeExtras
 
     void $ startTelemetry shakeDb shakeExtras
     startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras
 
+    checkParents <- optCheckParents
+    for_ metrics $ \store -> do
+        let readValuesCounter = fromIntegral . countRelevantKeys checkParents . HMap.keys <$> readVar (state shakeExtras)
+            readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readIORef (dirtyKeys shakeExtras)
+            readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
+            readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readVar (exportsMap shakeExtras)
+            readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
+            readDatabaseStep =  fromIntegral <$> shakeGetBuildStep shakeDb
+
+        registerGauge "ghcide.values_count" readValuesCounter store
+        registerGauge "ghcide.dirty_keys_count" readDirtyKeys store
+        registerGauge "ghcide.indexing_pending_count" readIndexPending store
+        registerGauge "ghcide.exports_map_count" readExportsMap store
+        registerGauge "ghcide.database_count" readDatabaseCount store
+        registerCounter "ghcide.num_builds" readDatabaseStep store
+
     return ideState
 
 startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())

ghcide/src/Development/IDE/Main.hs

@@ -8,13 +8,15 @@ module Development.IDE.Main
 ,commandP
 ,defaultMain
 ,testing) where
+import           Control.Concurrent                    (killThread)
+import           Control.Concurrent.Async              (async, waitCatch)
 import           Control.Concurrent.Extra              (newLock, readVar,
                                                         withLock,
                                                         withNumCapabilities)
 import           Control.Exception.Safe                (Exception (displayException),
-                                                        catchAny)
-import           Control.Monad.Extra                   (concatMapM, unless,
-                                                        when)
+                                                        catchAny, onException)
+import           Control.Monad.Extra                   (concatMapM, join,
+                                                        unless, when)
 import qualified Data.Aeson.Encode.Pretty              as A
 import           Data.Default                          (Default (def))
 import           Data.Foldable                         (traverse_)
@@ -29,6 +31,7 @@ import           Data.Text.Encoding                    (encodeUtf8)
 import qualified Data.Text.IO                          as T
 import           Data.Text.Lazy.Encoding               (decodeUtf8)
 import qualified Data.Text.Lazy.IO                     as LT
+import           Data.Traversable                      (for)
 import           Data.Typeable                         (typeOf)
 import           Data.Word                             (Word16)
 import           Development.IDE                       (Action, GhcVersion (..),
@@ -115,6 +118,9 @@ import           System.IO                             (BufferMode (LineBufferin
                                                         hSetBuffering,
                                                         hSetEncoding, stderr,
                                                         stdin, stdout, utf8)
+import qualified System.Metrics                        as Monitoring
+import           System.Remote.Monitoring.Wai
+import qualified System.Remote.Monitoring.Wai          as Monitoring
 import           System.Time.Extra                     (offsetTime,
                                                         showDuration)
 import           Text.Printf                           (printf)
@@ -181,6 +187,7 @@ data Arguments = Arguments
     , argsHandleIn              :: IO Handle
     , argsHandleOut             :: IO Handle
     , argsThreads               :: Maybe Natural
+    , argsMonitoringPort        :: Maybe Natural
     }
 
 instance Default Arguments where
@@ -219,6 +226,7 @@ defaultArguments priority = Arguments
                 -- the language server tests without the redirection.
                 putStr " " >> hFlush stdout
                 return newStdout
+        , argsMonitoringPort = Just 8000
         }
 
 testing :: Arguments
@@ -310,6 +318,24 @@ defaultMain Arguments{..} = do
                     hPutStrLn stderr $
                         "Currently, HLS supports GHC 9 only partially. "
                         <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."
+
+                server <- fmap join $ for argsMonitoringPort $ \p -> do
+                    store <- Monitoring.newStore
+                    let startServer = Monitoring.forkServerWith store "localhost" (fromIntegral p)
+                    -- this can fail if the port is busy, throwing an async exception back to us
+                    -- to handle that, wrap the server thread in an async
+                    mb_server <- async startServer >>= waitCatch
+                    case mb_server of
+                        Right s -> do
+                            logInfo logger $ T.pack $
+                                "Started monitoring server on port " <> show p
+                            return $ Just s
+                        Left e -> do
+                            logInfo logger $ T.pack $
+                                "Unable to bind monitoring server on port "
+                                <> show p <> ":" <> show e
+                            return Nothing
+
                 initialise
                     argsDefaultHlsConfig
                     rules
@@ -320,6 +346,9 @@ defaultMain Arguments{..} = do
                     vfs
                     hiedb
                     hieChan
+                    (Monitoring.serverMetricStore <$> server)
+                    `onException`
+                        traverse_ (killThread . serverThreadId) server
         Check argFiles -> do
           dir <- IO.getCurrentDirectory
           dbLoc <- getHieDbLoc dir
@@ -352,7 +381,7 @@ defaultMain Arguments{..} = do
                         , optCheckProject = pure False
                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                         }
-            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
+            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan Nothing
             shakeSessionInit ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
 
@@ -403,7 +432,7 @@ defaultMain Arguments{..} = do
                     , optCheckProject = pure False
                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                     }
-            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
+            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan Nothing
             shakeSessionInit ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
             c ide