diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 2283899d0c..7b81bb08e8 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -65,7 +65,7 @@ jobs: run: cabal v2-build hls-graph --flags="embed-files stm-stats" - name: Build `ghcide` with flags - run: cabal v2-build ghcide --flags="ghc-patched-unboxed-bytecode test-exe executable bench-exe" + run: cabal v2-build ghcide --flags="ghc-patched-unboxed-bytecode test-exe executable bench-exe ekg" # we have to clean up warnings for 9.0 and 9.2 before enable -WAll - if: matrix.ghc != '9.0.2' && matrix.ghc != '9.2.2' diff --git a/cabal.project b/cabal.project index 78ceb8e2ff..4cc16fa34a 100644 --- a/cabal.project +++ b/cabal.project @@ -53,6 +53,15 @@ constraints: ghc-lib-parser-ex -auto, stylish-haskell +ghc-lib +-- This is benign and won't affect our ability to release to Hackage, +-- because we only depend on `ekg-json` when a non-default flag +-- is turned on. +source-repository-package + type:git + location: https://github.com/pepeiborra/ekg-json + tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460 + -- https://github.com/tibbe/ekg-json/pull/12 + allow-newer: -- ghc-9.2 ---------- @@ -70,3 +79,13 @@ allow-newer: -- for shake-bench Chart:lens, Chart-diagrams:lens, + + -- for ekg + ekg-core:base, + ekg-core:ghc-prim, + ekg-wai:base, + ekg-wai:time, + + -- for shake-bench + Chart-diagrams:diagrams-core, + SVGFonts:diagrams-core diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index 2dde423b74..1907d40856 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -225,6 +225,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 + +When ghcide is built with the `ekg` flag, HLS opens a metrics server on port 8999 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](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/runtime_control.html#rts-eventlog) 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. diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 590a707570..a188671994 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -122,7 +122,6 @@ - Development.IDE.Plugin.Completions - Development.IDE.Plugin.Completions.Logic - Development.IDE.Types.Location - - Main - flags: - default: false diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 4b5e8ae0fa..4d14b920bd 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -19,6 +19,7 @@ data Arguments = Arguments ,argsVerbose :: Bool ,argsCommand :: Command ,argsConservativeChangeTracking :: Bool + ,argsMonitoringPort :: Int } getArguments :: IdePlugins IdeState -> IO Arguments @@ -40,6 +41,7 @@ arguments plugins = Arguments <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)") + <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)") where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client") diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 37bab4d72e..e97f393d2a 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -19,12 +19,13 @@ import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Tracing (withTelemetryLogger) import qualified Development.IDE.Main as IDEMain +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry +import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Info, Error), - Recorder (Recorder), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions) @@ -142,4 +143,5 @@ main = withTelemetryLogger $ \telemetryLogger -> do , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking } + , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort } diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 93bd51a950..030cc88aad 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -30,6 +30,11 @@ flag ghc-patched-unboxed-bytecode default: False manual: True +flag ekg + description: Enable EKG monitoring of the build graph and other metrics on port 8999 + default: False + manual: True + library default-language: Haskell2010 build-depends: @@ -182,6 +187,7 @@ library Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation Development.IDE.Import.FindImports + Development.IDE.Monitoring.EKG Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer Development.IDE.LSP.Outline @@ -198,6 +204,8 @@ library Development.IDE.Types.KnownTargets Development.IDE.Types.Location Development.IDE.Types.Logger + Development.IDE.Types.Monitoring + Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options Development.IDE.Types.Shake Development.IDE.Plugin @@ -236,6 +244,12 @@ library exposed-modules: Development.IDE.GHC.Compat.CPP + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG + flag test-exe description: Build the ghcide-test-preprocessor executable default: True @@ -356,6 +370,11 @@ executable ghcide if !flag(executable) buildable: False + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG test-suite ghcide-tests type: exitcode-stdio-1.0 diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 0dd04a2cd7..8ef090e84e 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -18,30 +18,30 @@ module Development.IDE.Core.Service( Log(..), ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log, LogShake) +import Development.IDE.Core.FileExists (fileExistsRules) +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, - Pretty (pretty), - Priority (Debug), - Recorder, - WithPriority, - cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Debug), + Recorder, + WithPriority, + cmapWithPrio) +import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP import Control.Monad -import qualified Development.IDE.Core.FileExists as FileExists -import qualified Development.IDE.Core.OfInterest as OfInterest -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Shake (WithHieDb) -import System.Environment (lookupEnv) - +import qualified Development.IDE.Core.FileExists as FileExists +import qualified Development.IDE.Core.OfInterest as OfInterest +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Types.Monitoring (Monitoring) +import Development.IDE.Types.Shake (WithHieDb) +import System.Environment (lookupEnv) data Log = LogShake Shake.Log @@ -68,8 +68,9 @@ initialise :: Recorder (WithPriority Log) -> IdeOptions -> WithHieDb -> IndexQueue + -> Monitoring -> IO IdeState -initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do +initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -86,6 +87,7 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options withH withHieDb hiedbChan (optShakeOptions options) + metrics $ do addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 808de1d1a6..fbd7c3795f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -118,7 +118,6 @@ import Data.Typeable import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector -import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping @@ -136,6 +135,7 @@ import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, + shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) @@ -152,6 +152,8 @@ import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint +import Language.LSP.Types.Capabilities +import OpenTelemetry.Eventlog import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS @@ -160,14 +162,13 @@ import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities import Language.LSP.VFS import qualified "list-t" ListT -import OpenTelemetry.Eventlog import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +import Development.IDE.Types.Monitoring (Monitoring(..)) data Log = LogCreateHieDbExportsMapStart @@ -388,7 +389,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do | otherwise = do pmap <- readTVarIO 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 @@ -462,6 +463,7 @@ data IdeState = IdeState ,shakeSession :: MVar ShakeSession ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) + ,stopMonitoring :: IO () } @@ -557,10 +559,13 @@ shakeOpen :: Recorder (WithPriority Log) -> WithHieDb -> IndexQueue -> ShakeOptions + -> Monitoring -> Rules () -> IO IdeState shakeOpen recorder lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo + shakeProfileDir (IdeReportProgress reportProgress) + ideTesting@(IdeTesting testing) + withHieDb indexQueue opts monitoring rules = mdo let log :: Logger.Priority -> Log -> IO () log = logWith recorder @@ -608,36 +613,40 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer rules shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir - let ideState = IdeState{..} IdeOptions { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle + , optCheckParents } <- getIdeOptionsIO shakeExtras - void $ startTelemetry shakeDb shakeExtras startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras - return ideState - -startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) -startTelemetry db extras@ShakeExtras{..} - | userTracingEnabled = do - countKeys <- mkValueObserver "cached keys count" - countDirty <- mkValueObserver "dirty keys count" - countBuilds <- mkValueObserver "builds count" - IdeOptions{optCheckParents} <- getIdeOptionsIO extras checkParents <- optCheckParents - regularly 1 $ do - observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state - readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList - shakeGetBuildStep db >>= observe countBuilds - | otherwise = async (pure ()) - where - regularly :: Seconds -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> sleep delay) + -- monitoring + let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) + readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) + readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) + readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb + readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb + + registerGauge monitoring "ghcide.values_count" readValuesCounter + registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys + registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending + registerGauge monitoring "ghcide.exports_map_count" readExportsMap + registerGauge monitoring "ghcide.database_count" readDatabaseCount + registerCounter monitoring "ghcide.num_builds" readDatabaseStep + + stopMonitoring <- start monitoring + + let ideState = IdeState{..} + return ideState + +getStateKeys :: ShakeExtras -> IO [Key] +getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () @@ -657,6 +666,7 @@ shakeShut IdeState{..} = do for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 43e9827c8b..5acb2139d5 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -62,6 +62,9 @@ import Development.IDE.LSP.LanguageServer (runLanguageServer) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats +import Development.IDE.Types.Monitoring (Monitoring) +import qualified Development.IDE.Monitoring.EKG as EKG +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS as PluginHLS @@ -231,9 +234,9 @@ data Arguments = Arguments , argsHandleIn :: IO Handle , argsHandleOut :: IO Handle , argsThreads :: Maybe Natural + , argsMonitoring :: IO Monitoring } - defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing @@ -268,6 +271,7 @@ defaultArguments recorder logger = Arguments -- the language server tests without the redirection. putStr " " >> hFlush stdout return newStdout + , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999 } @@ -355,6 +359,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re -- FIXME: Remove this after GHC 9 gets fully supported when (ghcVersion == GHC90) $ log Warning LogOnlyPartialGhc9Support + monitoring <- argsMonitoring initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig @@ -365,6 +370,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re options withHieDb hieChan + monitoring dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot @@ -397,7 +403,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -450,14 +456,11 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide -{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} - - expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do b <- IO.doesFileExist x diff --git a/ghcide/src/Development/IDE/Monitoring/EKG.hs b/ghcide/src/Development/IDE/Monitoring/EKG.hs new file mode 100644 index 0000000000..84bc85935a --- /dev/null +++ b/ghcide/src/Development/IDE/Monitoring/EKG.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Monitoring.EKG(monitoring) where + +import Development.IDE.Types.Monitoring (Monitoring (..)) +import Development.IDE.Types.Logger (Logger) +#ifdef MONITORING_EKG +import Control.Concurrent (killThread) +import Control.Concurrent.Async (async, waitCatch) +import Control.Monad (forM_) +import Data.Text (pack) +import Development.IDE.Types.Logger (logInfo) +import qualified System.Remote.Monitoring.Wai as Monitoring +import qualified System.Metrics as Monitoring + +-- | Monitoring using EKG +monitoring :: Logger -> Int -> IO Monitoring +monitoring logger port = do + store <- Monitoring.newStore + Monitoring.registerGcMetrics store + let registerCounter name read = Monitoring.registerCounter name read store + registerGauge name read = Monitoring.registerGauge name read store + start = do + server <- do + let startServer = Monitoring.forkServerWith store "localhost" port + -- 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 $ pack $ + "Started monitoring server on port " <> show port + return $ Just s + Left e -> do + logInfo logger $ pack $ + "Unable to bind monitoring server on port " + <> show port <> ":" <> show e + return Nothing + return $ forM_ server $ \s -> do + logInfo logger "Stopping monitoring server" + killThread $ Monitoring.serverThreadId s + return $ Monitoring {..} + +#else + +monitoring :: Logger -> Int -> IO Monitoring +monitoring _ _ = mempty + +#endif diff --git a/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs b/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs new file mode 100644 index 0000000000..2a6efa3d2e --- /dev/null +++ b/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs @@ -0,0 +1,31 @@ +module Development.IDE.Monitoring.OpenTelemetry (monitoring) where + +import Control.Concurrent.Async (Async, async, cancel) +import Control.Monad (forever) +import Data.IORef.Extra (atomicModifyIORef'_, + newIORef, readIORef) +import Data.Text.Encoding (encodeUtf8) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Types.Monitoring (Monitoring (..)) +import OpenTelemetry.Eventlog (mkValueObserver, observe) +import System.Time.Extra (Seconds, sleep) + +-- | Dump monitoring to the eventlog using the Opentelemetry package +monitoring :: IO Monitoring +monitoring + | userTracingEnabled = do + actions <- newIORef [] + let registerCounter name read = do + observer <- mkValueObserver (encodeUtf8 name) + let update = observe observer . fromIntegral =<< read + atomicModifyIORef'_ actions (update :) + registerGauge = registerCounter + let start = do + a <- regularly 1 $ sequence_ =<< readIORef actions + return (cancel a) + return Monitoring{..} + | otherwise = mempty + + +regularly :: Seconds -> IO () -> IO (Async ()) +regularly delay act = async $ forever (act >> sleep delay) diff --git a/ghcide/src/Development/IDE/Types/Monitoring.hs b/ghcide/src/Development/IDE/Types/Monitoring.hs new file mode 100644 index 0000000000..256381e60a --- /dev/null +++ b/ghcide/src/Development/IDE/Types/Monitoring.hs @@ -0,0 +1,32 @@ +module Development.IDE.Types.Monitoring +(Monitoring(..) +) where + +import Data.Int +import Data.Text (Text) + +-- | An abstraction for runtime monitoring inspired by the 'ekg' package +data Monitoring = Monitoring { + -- | Register an integer-valued metric. + registerGauge :: Text -> IO Int64 -> IO (), + -- | Register a non-negative, monotonically increasing, integer-valued metric. + registerCounter :: Text -> IO Int64 -> IO (), + start :: IO (IO ()) -- ^ Start the monitoring system, returning an action which will stop the system. + } + +instance Semigroup Monitoring where + a <> b = Monitoring { + registerGauge = \n v -> registerGauge a n v >> registerGauge b n v, + registerCounter = \n v -> registerCounter a n v >> registerCounter b n v, + start = do + a' <- start a + b' <- start b + return $ a' >> b' + } + +instance Monoid Monitoring where + mempty = Monitoring { + registerGauge = \_ _ -> return (), + registerCounter = \_ _ -> return (), + start = return $ return () + } diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 53406bc3dd..1d5aab3789 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -9,6 +9,7 @@ module Development.IDE.Graph.Database( shakeRunDatabaseForKeys, shakeProfileDatabase, shakeGetBuildStep, + shakeGetDatabaseKeys, shakeGetDirtySet, shakeGetCleanKeys ,shakeGetBuildEdges) where @@ -79,3 +80,8 @@ shakeGetBuildEdges (ShakeDatabase _ _ db) = do keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress + +-- | Returns an approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index a6282a05eb..0ed2ccbb64 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -199,7 +199,7 @@ getDirtySet db = do calcAgeStatus _ = Nothing return $ mapMaybe (secondM calcAgeStatus) dbContents --- | Returns ann approximation of the database keys, +-- | Returns an approximation of the database keys, -- annotated with how long ago (in # builds) they were visited getKeysAndVisitAge :: Database -> IO [(Key, Int)] getKeysAndVisitAge db = do