From e24a744a06ee8807fd0a2c6b2db3f4eed0738372 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 5 Dec 2020 17:44:17 +0000 Subject: [PATCH] Opentelemetry traces and heapsize memory analysis (#922) * Move tracing functions to own module * Bump opentelemetry to 0.6.0 * Write Values map size to OpenTelemetry metric * Trace all requests and notifications Instead of doing it in `HoverDefinition`, do it in with{Response,Notification,...}. These wrap all handlers, so this should cover everything. It also means that the span covers the entire processing time for the request, where before we missed the setup happening in the with* functions. * Add flag for OpenTelemetry profiling Run GC regularly with --ot-profiling * Add flag to enable OT profiling in benchmark * Use heapsize instead of ghc-datasize I renamed the fork to distringuish from the original. It is still being pulled from git using stack. This will be addressed once I can push the fork to hackage. * Bump opentelemetry to 0.6.1 - fixes 8.6 build * Use heapsize from hackage * Address HLint messages * Record size of each key independently * Refactor `startTelemetry` function * Remove delay between measuring memory loops * Each key in values map gets own OT instrument * Measure values map length more rarely * Rename --ot-profiling to --ot-memory-profiling * Add docs for how to use the opentelemetry output * Add instructions to build release version of tracy * Clarify dependencies in opentelemetry instructions * Fix LSP traces * otTraced: delete unused * Extract types out of D.IDE.Core.Shake to avoid circular module dependencies * Extract startTelemetry out of D.IDE.Shake and upgrade to 0.2 No more segfaults * [nix] install opentelemetry * [nix] install tracy * Fix merge wibble * Measure recursive sizes with sharing * Sort keys for cost attribution * Remove debug traces * Allocate less, group keys, clean up hlints * Add -A4G to the flags used for --ot-memory-profiling * Modularize D.IDE.Core.Tracing I want to reuse this code more directly in the non lsp driver * Direct driver: report closure sizes when --ot-memory-profiling An eventlog memory analysis doesnt' seem so relevant since this mode is not interactive, but we could easily produce both if wanted to * Everything is reachable from GhcSessionIO, so compute it last I suspect the ShakeExtras record is reachable from GhcSessionIO * bound recursion and use logger * hlint suggestions * Fix 8.6 build * Format imports * Do the memory analysis with full sharing. GhcSessionIO last * Fail fast in the memory analysis * error handling * runHeapsize now takes initSize as an input argument * Trace Shake sessions * Reduced frequency for sampling values length * Drop the -fexternal-interpreter flag in the Windows stack build * Produce more benchmark artifacts * Fix stack descriptors to use heapsize-0.2 from Hackage * Bump to heapsize-0.3.0 * Record completions snippets (#900) * Add field for RecordSnippets to CachcedCompletion * Initial version of local record snippets * Supprt record snippet completion for non local declarations. * Better integration of local completions with current implementation * Clean up non-local completions. * Remove commented code. * Switch from String to Text * Remove ununsed definition * Treat only Records and leave other defintions as is. * Differentiate Records from Data constructors for external declaration * Update test to include snippet in local record completions expected list. * Update completionTest to also compare insertText. * Add test for record snippet completion for imported records. * Hlint fixes * Hlint fixes * Hlint suggestions. * Update type. * Consolidate imports * Unpack tuple with explicit names * Idiomatic changes * Remove unused variable * Better variable name * Hlint suggestions * Handle exhaustive pattern warning * Add _ to snippet field name suggestions * Remove type information passed around but not used * Update to list comprehension style * Eliminate intermediate function * HLint suggestions. * Idiomatic list comprehension Co-authored-by: Pepe Iborra * [nix] use gitignore.nix (#920) * Ignore import list while producing completions (#919) * Drop any items in explicit import list * Test if imports not included in explicit list show up in completions * Update README.md (#924) * Custom cradle loading (#928) When using ghcide as a library, it may be desirable to host the hie.yaml file in a location other than the project root, or even avoid the file system altogether * Favor `lookupPathToId` over `pathToId` (#926) * Favor `lookupPathToId` over `pathToId` * Fix `typecheckParentsAction` * Fix `needsCompilationRule` * Return completion snippets only when client supports it (#929) * Use the real client capabilities on completions * Return completion snippets only when supported by the client Restored from https://github.com/haskell/ghcide/pull/900 * Redundant import * Fix stack windows build Co-authored-by: Michalis Pardalos Co-authored-by: Michalis Pardalos Co-authored-by: Guru Devanla Co-authored-by: Samuel Ainsworth --- .github/workflows/bench.yml | 2 +- bench/lib/Experiments.hs | 16 +- bench/lib/Experiments/Types.hs | 1 + docs/opentelemetry.md | 66 ++++++++ exe/Arguments.hs | 2 + exe/Main.hs | 50 ++++-- ghcide.cabal | 9 +- shell.nix | 6 +- src/Development/IDE.hs | 3 +- src/Development/IDE/Core/RuleTypes.hs | 17 +- src/Development/IDE/Core/Rules.hs | 10 -- src/Development/IDE/Core/Shake.hs | 71 +++------ src/Development/IDE/Core/Tracing.hs | 179 ++++++++++++++++++++++ src/Development/IDE/LSP/LanguageServer.hs | 22 ++- src/Development/IDE/Types/KnownTargets.hs | 24 +++ src/Development/IDE/Types/Options.hs | 12 +- src/Development/IDE/Types/Shake.hs | 41 +++++ stack-windows.yaml | 26 ++++ stack.yaml | 5 + 19 files changed, 465 insertions(+), 97 deletions(-) create mode 100644 docs/opentelemetry.md create mode 100644 src/Development/IDE/Core/Tracing.hs create mode 100644 src/Development/IDE/Types/KnownTargets.hs create mode 100644 src/Development/IDE/Types/Shake.hs diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 0447e22b..9fd57a7d 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -55,4 +55,4 @@ jobs: name: bench-results-${{ runner.os }}-${{ matrix.ghc }} path: | bench-results/results.* - bench-results/*.svg + bench-results/**/*.svg diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs index bafdfd89..01f23184 100644 --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -40,7 +40,7 @@ import Numeric.Natural import Options.Applicative import System.Directory import System.Environment.Blank (getEnv) -import System.FilePath (()) +import System.FilePath ((), (<.>)) import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S) @@ -129,7 +129,6 @@ exampleModulePath = exampleModule (example ?config) examplesPath :: FilePath examplesPath = "bench/example" - defConfig :: Config Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] @@ -147,6 +146,7 @@ configP = <|> pure Normal ) <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) + <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR")) <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)") <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide")) @@ -212,6 +212,10 @@ runBenchmarksFun dir allBenchmarks = do let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) } | b <- allBenchmarks , select b ] + + whenJust (otMemoryProfiling ?config) $ \eventlogDir -> + createDirectoryIfMissing True eventlogDir + results <- forM benchmarks $ \b@Bench{name} -> let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir in (b,) <$> runBench run b @@ -278,14 +282,18 @@ runBenchmarksFun dir allBenchmarks = do "--cwd", dir, "+RTS", - "-S" <> gcStats name, - "-RTS" + "-S" <> gcStats name ] + ++ case otMemoryProfiling ?config of + Just dir -> ["-l", "-ol" ++ (dir (map (\c -> if c == ' ' then '-' else c) name) <.> "eventlog")] + Nothing -> [] + ++ [ "-RTS" ] ++ ghcideOptions ?config ++ concat [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] ] ++ ["--verbose" | verbose ?config] + ++ if isJust (otMemoryProfiling ?config) then [ "--ot-memory-profiling" ] else [] lspTestCaps = fullCaps {_window = Just $ WindowClientCapabilities $ Just True} conf = diff --git a/bench/lib/Experiments/Types.hs b/bench/lib/Experiments/Types.hs index f56441a0..80534bdb 100644 --- a/bench/lib/Experiments/Types.hs +++ b/bench/lib/Experiments/Types.hs @@ -18,6 +18,7 @@ data Config = Config { verbosity :: !Verbosity, -- For some reason, the Shake profile files are truncated and won't load shakeProfiling :: !(Maybe FilePath), + otMemoryProfiling :: !(Maybe FilePath), outputCSV :: !FilePath, buildTool :: !CabalStack, ghcideOptions :: ![String], diff --git a/docs/opentelemetry.md b/docs/opentelemetry.md new file mode 100644 index 00000000..81c915a2 --- /dev/null +++ b/docs/opentelemetry.md @@ -0,0 +1,66 @@ +# Using opentelemetry + +`ghcide` has support for opentelemetry-based tracing. This allows for tracing +the execution of the process, seeing when Shake rules fire and for how long they +run, when LSP messages are received, and (currently WIP) measuring the memory +occupancy of different objects in memory. + +## Capture opentlemetry data + +Capturing of opentelemetry data can be enabled by first building ghcide with eventlog support: + +```sh +stack build --ghc-options -eventlog +``` + +Then, you can run `ghcide`, giving it a file to dump eventlog information into. + +```sh +ghcide +RTS -l -ol ghcide.eventlog -RTS +``` + +You can also optionally enable reporting detailed memory data with `--ot-memory-profiling` + +```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. + +## Viewing with tracy + +After installing `opentelemetry-extra` and `tracy`, you can view the opentelementry output: + +```sh +eventlog-to-tracy ghcide.eventlog +``` + +If everything has been set up correctly, this should open a tracy window with the tracing data you captured + +### Installing opentelemetry-extra + +This package includes a number of binaries for converting between the eventlog output and the formats that various opentelemetry viewers (like tracy) can display: + +```sh +cabal install openetelemetry-extra +``` + + + +### Building tracy + +1. Install the dependencies: `pkg-config` and `glfw, freetype, capstone, GTK3`, along + with their header files (`-dev` on most distros. On Arch the header + files are included with the normal packages). +2. Download tracy from https://github.com/wolfpld/tracy +3. `cd` into the directory containing the source you downloaded +4. Build the `import-chrome` and `Tracy` libraries: + ```sh + make -C profiler/build/unix release + make -C import-chrome/build/unix release + ``` +5. Copy the binaries to your `$PATH`: + ```sh + cp profiler/build/unix/Tracy-release ~/.local/bin/Tracy + cp import-chrome/build/unix/import-chrome-release ~/.local/bin/import-chrome + ``` diff --git a/exe/Arguments.hs b/exe/Arguments.hs index 22f035a4..37f238b6 100644 --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -12,6 +12,7 @@ data Arguments = Arguments ,argFiles :: [FilePath] ,argsVersion :: Bool ,argsShakeProfiling :: Maybe FilePath + ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool ,argsThreads :: Int ,argsVerbose :: Bool @@ -32,6 +33,7 @@ arguments = Arguments <*> many (argument str (metavar "FILES/DIRS...")) <*> switch (long "version" <> help "Show ghcide and GHC versions") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") + <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") diff --git a/exe/Main.hs b/exe/Main.hs index 1b08985c..7c7ab596 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -51,6 +51,9 @@ import qualified Data.Aeson as J import HIE.Bios.Cradle import Development.IDE (action) +import Text.Printf +import Development.IDE.Core.Tracing +import Development.IDE.Types.Shake (Key(Key)) ghcideVersion :: IO String ghcideVersion = do @@ -105,12 +108,13 @@ main = do sessionLoader <- loadSession $ fromMaybe dir rootPath config <- fromMaybe defaultLspConfig <$> getConfig let options = (defaultIdeOptions sessionLoader) - { optReportProgress = clientSupportsProgress caps - , optShakeProfiling = argsShakeProfiling - , optTesting = IdeTesting argsTesting - , optThreads = argsThreads - , optCheckParents = checkParents config - , optCheckProject = checkProject config + { optReportProgress = clientSupportsProgress caps + , optShakeProfiling = argsShakeProfiling + , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling + , optTesting = IdeTesting argsTesting + , optThreads = argsThreads + , optCheckParents = checkParents config + , optCheckProject = checkProject config } logLevel = if argsVerbose then minBound else Info debouncer <- newAsyncDebouncer @@ -139,22 +143,46 @@ main = do putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle debouncer <- newAsyncDebouncer - let logLevel = if argsVerbose then minBound else Info - dummyWithProg _ _ f = f (const (pure ())) + let dummyWithProg _ _ f = f (const (pure ())) sessionLoader <- loadSession dir - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer (defaultIdeOptions sessionLoader) vfs + let options = (defaultIdeOptions sessionLoader) + { optShakeProfiling = argsShakeProfiling + -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling + , optTesting = IdeTesting argsTesting + , optThreads = argsThreads + } + logLevel = if argsVerbose then minBound else Info + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) let (worked, failed) = partition fst $ zip (map isJust results) files when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" - putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)" + let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" + + when argsOTMemoryProfiling $ do + let valuesRef = state $ shakeExtras ide + values <- readVar valuesRef + let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) + consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) + + printf "# Shake value store contents(%d):\n" (length values) + let keys = nub + $ Key GhcSession : Key GhcSessionDeps + : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO] + ++ [Key GhcSessionIO] + measureMemory (logger logLevel) [keys] consoleObserver valuesRef + unless (null failed) (exitWith $ ExitFailure (length failed)) +{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-} + expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do b <- IO.doesFileExist x diff --git a/ghcide.cabal b/ghcide.cabal index 4fc960f7..39945fa9 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -57,6 +57,7 @@ library hie-compat, mtl, network-uri, + parallel, prettyprinter-ansi-terminal, prettyprinter-ansi-terminal, prettyprinter, @@ -73,7 +74,9 @@ library transformers, unordered-containers >= 0.2.10.0, utf8-string, - hslogger + hslogger, + opentelemetry >=0.6.1, + heapsize ==0.3.* if flag(ghc-lib) build-depends: ghc-lib >= 8.8, @@ -134,6 +137,7 @@ library Development.IDE.Core.RuleTypes Development.IDE.Core.Service Development.IDE.Core.Shake + Development.IDE.Core.Tracing Development.IDE.GHC.Compat Development.IDE.GHC.Error Development.IDE.GHC.Orphans @@ -149,9 +153,11 @@ library Development.IDE.Spans.LocalBindings Development.IDE.Types.Diagnostics Development.IDE.Types.Exports + Development.IDE.Types.KnownTargets Development.IDE.Types.Location Development.IDE.Types.Logger Development.IDE.Types.Options + Development.IDE.Types.Shake Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction @@ -262,6 +268,7 @@ executable ghcide hashable, haskell-lsp, haskell-lsp-types, + heapsize, hie-bios, ghcide, lens, diff --git a/shell.nix b/shell.nix index 21fe54dd..2a235f2a 100644 --- a/shell.nix +++ b/shell.nix @@ -29,15 +29,19 @@ haskellPackagesForProject.shellFor { gmp zlib ncurses + capstone + tracy haskellPackages.cabal-install haskellPackages.hlint haskellPackages.ormolu haskellPackages.stylish-haskell + haskellPackages.opentelemetry-extra ]; src = null; shellHook = '' - export LD_LIBRARY_PATH=${gmp}/lib:${zlib}/lib:${ncurses}/lib + export LD_LIBRARY_PATH=${gmp}/lib:${zlib}/lib:${ncurses}/lib:${capstone}/lib + export DYLD_LIBRARY_PATH=${gmp}/lib:${zlib}/lib:${ncurses}/lib:${capstone}/lib export PATH=$PATH:$HOME/.local/bin ''; } diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs index 269246fc..91cec08d 100644 --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -8,8 +8,7 @@ module Development.IDE import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Rules as X - (GhcSessionIO(..) - ,getAtPoint + (getAtPoint ,getDefinition ,getParsedModule ,getTypeDefinition diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index e682116f..1291fc95 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -18,7 +18,7 @@ import Data.Binary import Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util -import Development.IDE.Core.Shake (KnownTargets) +import Development.IDE.Types.KnownTargets import Data.Hashable import Data.Typeable import qualified Data.Set as S @@ -36,6 +36,7 @@ import Data.ByteString (ByteString) import Language.Haskell.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) import qualified Data.ByteString.Char8 as BS +import Development.IDE.Types.Options (IdeGhcSession) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show) @@ -138,10 +139,10 @@ data HieAstResult -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same -- as that of `hieAst` } - + instance NFData HieAstResult where rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf - + instance Show HieAstResult where show = show . hieModule @@ -335,3 +336,13 @@ instance NFData GetClientSettings instance Binary GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) + +-- A local rule type to get caching. We want to use newCache, but it has +-- thread killed exception issues, so we lift it to a full rule. +-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 +type instance RuleResult GhcSessionIO = IdeGhcSession + +data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) +instance Hashable GhcSessionIO +instance NFData GhcSessionIO +instance Binary GhcSessionIO diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 96700d16..e97f16d5 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -624,16 +624,6 @@ currentLinkables = do where go (mod, time) = LM time mod [] --- A local rule type to get caching. We want to use newCache, but it has --- thread killed exception issues, so we lift it to a full rule. --- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 -type instance RuleResult GhcSessionIO = IdeGhcSession - -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) -instance Hashable GhcSessionIO -instance NFData GhcSessionIO -instance Binary GhcSessionIO - loadGhcSession :: Rules () loadGhcSession = do -- This function should always be rerun because it tracks changes diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index b21345c6..6b2d1a25 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} @@ -70,7 +69,6 @@ import Development.Shake hiding (ShakeValue, doesFileExist, Info) import Development.Shake.Database import Development.Shake.Classes import Development.Shake.Rule -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS @@ -78,17 +76,18 @@ import Data.Dynamic import Data.Maybe import Data.Map.Strict (Map) import Data.List.Extra (partition, takeEnd) -import Data.HashSet (HashSet) import qualified Data.Set as Set import qualified Data.Text as T import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer -import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache ) +import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache ) import Development.IDE.GHC.Orphans () import Development.IDE.Core.PositionMapping import Development.IDE.Types.Action import Development.IDE.Types.Logger hiding (Priority) +import Development.IDE.Types.KnownTargets +import Development.IDE.Types.Shake import qualified Development.IDE.Types.Logger as Logger import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL @@ -119,14 +118,15 @@ import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Traversable import Data.Hashable +import Development.IDE.Core.Tracing import Data.IORef import NameCache import UniqSupply import PrelInfo import Data.Int (Int64) -import qualified Data.HashSet as HSet import Language.Haskell.LSP.Types.Capabilities +import OpenTelemetry.Eventlog -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -168,16 +168,6 @@ data ShakeExtras = ShakeExtras ,clientCapabilities :: ClientCapabilities } --- | A mapping of module name to known files -type KnownTargets = HashMap Target [NormalizedFilePath] - -data Target = TargetModule ModuleName | TargetFile NormalizedFilePath - deriving ( Eq, Generic, Show ) - deriving anyclass (Hashable, NFData) - -toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath -toKnownFiles = HSet.fromList . concat . HMap.elems - type WithProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a. @@ -228,22 +218,6 @@ getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a getIdeGlobalState = getIdeGlobalExtras . shakeExtras --- | The state of the all values. -type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic) - --- | Key type -data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k - -instance Show Key where - show (Key k) = show k - -instance Eq Key where - Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2' - | otherwise = False - -instance Hashable Key where - hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) - newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions instance IsIdeGlobal GlobalIdeOptions @@ -257,21 +231,6 @@ getIdeOptionsIO ide = do GlobalIdeOptions x <- getIdeGlobalExtras ide return x -data Value v - = Succeeded TextDocumentVersion v - | Stale TextDocumentVersion v - | Failed - deriving (Functor, Generic, Show) - -instance NFData v => NFData (Value v) - --- | Convert a Value to a Maybe. This will only return `Just` for --- up2date results not for stale values. -currentValue :: Value v -> Maybe v -currentValue (Succeeded _ v) = Just v -currentValue (Stale _ _) = Nothing -currentValue Failed = Nothing - -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping)) @@ -446,6 +405,11 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie initSession <- newSession shakeExtras shakeDb [] shakeSession <- newMVar initSession let ideState = IdeState{..} + + IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras + when otProfilingEnabled $ + startTelemetry logger $ state shakeExtras + return ideState where -- The progress thread is a state machine with two states: @@ -619,11 +583,12 @@ newSession extras@ShakeExtras{..} shakeDb acts = do let -- A daemon-like action used to inject additional work -- Runs actions from the work queue sequentially - pumpActionThread = do + pumpActionThread otSpan = do d <- liftIO $ atomically $ popQueue actionQueue - void $ parallel [run d, pumpActionThread] + void $ parallel [run otSpan d, pumpActionThread otSpan] - run d = do + -- TODO figure out how to thread the otSpan into defineEarlyCutoff + run _otSpan d = do start <- liftIO offsetTime getAction d liftIO $ atomically $ doneQueue d actionQueue @@ -634,8 +599,8 @@ newSession extras@ShakeExtras{..} shakeDb acts = do logPriority logger (actionPriority d) msg notifyTestingLogMessage extras msg - workRun restore = do - let acts' = pumpActionThread : map run (reenqueued ++ acts) + workRun restore = withSpan "Shake session" $ \otSpan -> do + let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') let res' = case res of Left e -> "exception: " <> displayException e @@ -865,7 +830,7 @@ defineEarlyCutoff :: IdeRule k v => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) -> Rules () -defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do +defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file $ do extras@ShakeExtras{state, inProgress} <- getShakeExtras -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs new file mode 100644 index 00000000..c6069ff0 --- /dev/null +++ b/src/Development/IDE/Core/Tracing.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DataKinds #-} +module Development.IDE.Core.Tracing + ( otTracedHandler + , otTracedAction + , startTelemetry + , measureMemory + , getInstrumentCached + ) +where + +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (Var, modifyVar_, newVar, + readVar, threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (catch, SomeException) +import Control.Monad (forM_, forever, (>=>)) +import Control.Monad.Extra (whenJust) +import Control.Seq (r0, seqList, seqTuple2, using) +import Data.Dynamic (Dynamic) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.List (nub) +import Data.String (IsString (fromString)) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + GhcSessionIO (GhcSessionIO)) +import Development.IDE.Types.Logger (logInfo, Logger, logDebug) +import Development.IDE.Types.Shake (Key (..), Value, Values) +import Development.Shake (Action, actionBracket, liftIO) +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, + mkValueObserver, observe, + setTag, withSpan, withSpan_) + +-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. +otTracedHandler + :: String -- ^ Message type + -> String -- ^ Message label + -> IO a + -> IO a +otTracedHandler requestType label act = + let !name = + if null label + then requestType + else requestType <> ":" <> show label + -- Add an event so all requests can be quickly seen in the viewer without searching + in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act) + +-- | Trace a Shake action using opentelemetry. +otTracedAction + :: Show k + => k -- ^ The Action's Key + -> NormalizedFilePath -- ^ Path to the file the action was run for + -> Action a -- ^ The action + -> Action a +otTracedAction key file act = actionBracket + (do + sp <- beginSpan (fromString (show key)) + setTag sp "File" (fromString $ fromNormalizedFilePath file) + return sp + ) + endSpan + (const act) + +startTelemetry :: Logger -> Var Values -> IO () +startTelemetry 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 () + where + seconds = 1000000 + + regularly :: Int -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> threadDelay delay) + +{-# ANN startTelemetry ("HLint: ignore Use nubOrd" :: String) #-} + +type OurValueObserver = Int -> IO () + +getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) +getInstrumentCached = do + instrumentMap <- newVar HMap.empty + mapBytesInstrument <- mkValueObserver "value map size_bytes" + + let instrumentFor k = do + mb_inst <- HMap.lookup k <$> readVar instrumentMap + case mb_inst of + Nothing -> do + instrument <- mkValueObserver (fromString (show k ++ " size_bytes")) + modifyVar_ instrumentMap (return . HMap.insert k instrument) + return $ observe instrument + Just v -> return $ observe v + return $ maybe (return $ observe mapBytesInstrument) instrumentFor + +whenNothing :: IO () -> IO (Maybe a) -> IO () +whenNothing act mb = mb >>= f + where f Nothing = act + f Just{} = return () + +measureMemory + :: Logger + -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis + -> (Maybe Key -> IO OurValueObserver) + -> Var Values + -> IO () +measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do + values <- readVar stateRef + valuesSizeRef <- newIORef $ Just 0 + let !groupsOfGroupedValues = groupValues values + logDebug logger "STARTING MEMORY PROFILING" + forM_ groupsOfGroupedValues $ \groupedValues -> do + keepGoing <- readIORef valuesSizeRef + whenJust keepGoing $ \_ -> + whenNothing (writeIORef valuesSizeRef Nothing) $ + repeatUntilJust 3 $ do + -- logDebug logger (fromString $ show $ map fst groupedValues) + runHeapsize 25000000 $ + forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do + acc <- liftIO $ newIORef 0 + observe <- liftIO $ instrumentFor $ Just k + mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v + size <- liftIO $ readIORef acc + let !byteSize = sizeOf (undefined :: Word) * size + setTag sp "size" (fromString (show byteSize ++ " bytes")) + () <- liftIO $ observe byteSize + liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize)) + + mbValuesSize <- readIORef valuesSizeRef + case mbValuesSize of + Just valuesSize -> do + observe <- instrumentFor Nothing + observe valuesSize + logDebug logger "MEMORY PROFILING COMPLETED" + Nothing -> + logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" + + where + groupValues :: Values -> [ [(Key, [Value Dynamic])] ] + groupValues values = + let !groupedValues = + [ [ (k, vv) + | k <- groupKeys + , let vv = [ v | ((_,k'), v) <- HMap.toList values , k == k'] + ] + | groupKeys <- groups + ] + -- force the spine of the nested lists + in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0))) + +repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a) +repeatUntilJust 0 _ = return Nothing +repeatUntilJust nattempts action = do + res <- action + case res of + Nothing -> repeatUntilJust (nattempts-1) action + Just{} -> return res diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index 5536be97..9a3c37a1 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -36,6 +36,7 @@ import Development.IDE.LSP.Notifications import Development.IDE.LSP.Outline import Development.IDE.Types.Logger import Development.IDE.Core.FileStore +import Development.IDE.Core.Tracing import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages @@ -79,14 +80,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat -- The set of requests that have been cancelled and are also in pendingRequests cancelledRequests <- newTVarIO Set.empty - let withResponse wrap f = Just $ \r@RequestMessage{_id} -> do + let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do atomically $ modifyTVar pendingRequests (Set.insert _id) writeChan clientMsgChan $ Response r wrap f - let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) - let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do + let withNotification old f = Just $ \r@NotificationMessage{_method} -> + writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) + let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do atomically $ modifyTVar pendingRequests (Set.insert _id) writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f - let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x) + let withInitialize f = Just $ \r -> + writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x) let cancelRequest reqId = atomically $ do queued <- readTVar pendingRequests -- We want to avoid that the list of cancelled requests @@ -144,18 +147,20 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled case msg of - Notification x@NotificationMessage{_params} act -> do + Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do catch (act lspFuncs ide _params) $ \(e :: SomeException) -> logError (ideLogger ide) $ T.pack $ "Unexpected exception on notification, please report!\n" ++ "Message: " ++ show x ++ "\n" ++ "Exception: " ++ show e - Response x@RequestMessage{_id, _params} wrap act -> void $ async $ + Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $ + otTracedHandler "Request" (show _method) $ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \case Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) - ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act -> void $ async $ + ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $ + otTracedHandler "Request" (show _method) $ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \(res, newReq) -> do case res of @@ -164,7 +169,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat whenJust newReq $ \(rm, newReqParams) -> do reqId <- getNextReqId sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams - InitialParams x@RequestMessage{_id, _params} act -> do + InitialParams x@RequestMessage{_id, _method, _params} act -> + otTracedHandler "Initialize" (show _method) $ catch (act lspFuncs ide _params) $ \(e :: SomeException) -> logError (ideLogger ide) $ T.pack $ "Unexpected exception on InitializeRequest handler, please report!\n" ++ diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs new file mode 100644 index 00000000..529edc21 --- /dev/null +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where + +import Data.HashMap.Strict +import Development.IDE.Types.Location +import Development.IDE.GHC.Compat (ModuleName) +import Development.IDE.GHC.Orphans () +import Data.Hashable +import GHC.Generics +import Control.DeepSeq +import Data.HashSet +import qualified Data.HashSet as HSet +import qualified Data.HashMap.Strict as HMap + +-- | A mapping of module name to known files +type KnownTargets = HashMap Target [NormalizedFilePath] + +data Target = TargetModule ModuleName | TargetFile NormalizedFilePath + deriving ( Eq, Generic, Show ) + deriving anyclass (Hashable, NFData) + +toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath +toKnownFiles = HSet.fromList . concat . HMap.elems diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs index 105895d5..7bc38e7e 100644 --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -15,6 +15,7 @@ module Development.IDE.Types.Options , IdeReportProgress(..) , IdeDefer(..) , IdeTesting(..) + , IdeOTMemoryProfiling(..) , clientSupportsProgress , IdePkgLocationOptions(..) , defaultIdeOptions @@ -68,6 +69,9 @@ data IdeOptions = IdeOptions -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds. , optShakeProfiling :: Maybe FilePath -- ^ Set to 'Just' to create a directory of profiling reports. + , optOTMemoryProfiling :: IdeOTMemoryProfiling + -- ^ Whether to record profiling information with OpenTelemetry. You must + -- also enable the -l RTS flag for this to have any effect , optTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress @@ -134,9 +138,10 @@ data IdePreprocessedSource = IdePreprocessedSource -- ^ New parse tree emitted by the preprocessor. } -newtype IdeReportProgress = IdeReportProgress Bool -newtype IdeDefer = IdeDefer Bool -newtype IdeTesting = IdeTesting Bool +newtype IdeReportProgress = IdeReportProgress Bool +newtype IdeDefer = IdeDefer Bool +newtype IdeTesting = IdeTesting Bool +newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == @@ -151,6 +156,7 @@ defaultIdeOptions session = IdeOptions ,optThreads = 0 ,optShakeFiles = Nothing ,optShakeProfiling = Nothing + ,optOTMemoryProfiling = IdeOTMemoryProfiling False ,optReportProgress = IdeReportProgress False ,optLanguageSyntax = "haskell" ,optNewColonConvention = False diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs new file mode 100644 index 00000000..b2af70c7 --- /dev/null +++ b/src/Development/IDE/Types/Shake.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Development.IDE.Types.Shake (Value(..), Values, Key(..), currentValue) where + +import Control.DeepSeq +import Data.Dynamic +import Data.Hashable +import Data.HashMap.Strict +import Data.Typeable +import GHC.Generics +import Language.Haskell.LSP.Types + +data Value v + = Succeeded TextDocumentVersion v + | Stale TextDocumentVersion v + | Failed + deriving (Functor, Generic, Show) + +instance NFData v => NFData (Value v) + +-- | Convert a Value to a Maybe. This will only return `Just` for +-- up2date results not for stale values. +currentValue :: Value v -> Maybe v +currentValue (Succeeded _ v) = Just v +currentValue (Stale _ _) = Nothing +currentValue Failed = Nothing + +-- | The state of the all values. +type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic) + +-- | Key type +data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k + +instance Show Key where + show (Key k) = show k + +instance Eq Key where + Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2' + | otherwise = False + +instance Hashable Key where + hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) diff --git a/stack-windows.yaml b/stack-windows.yaml index e5452a6e..80b83108 100644 --- a/stack-windows.yaml +++ b/stack-windows.yaml @@ -9,6 +9,11 @@ extra-deps: - lsp-test-0.11.0.6 - ghc-check-0.5.0.1 - hie-bios-0.7.1 +- ghc-events-0.13.0 +- ghc-trace-events-0.1.2.1 +- heapsize-0.3.0 +- opentelemetry-0.6.1 +- opentelemetry-extra-0.6.1 # not yet in stackage - Chart-diagrams-1.9.3 @@ -30,3 +35,24 @@ extra-deps: nix: packages: [zlib] + +configure-options: + heapsize: + - --disable-library-for-ghci + - --disable-library-stripping +# Otherwise the ghcide will fail with: +# ``` +# ghcide > ghc.exe: unable to load package `heapsize-0.2' +# ghcide > ghc-iserv: | D:\a\1\s\.stack-work\install\52d658b2\lib\x86_64-windows-ghc-8.10.1\heapsize-0.2-KCPoGpPDcevACNftTTY2at\HSheapsize-0.2-KCPoGpPDcevACNftTTY2at.o: unknown symbol `heap_view_closurePtrs' +# +# Cause: +# The pre-linked object file is missing the heapsize_prim.o symbols table (from the cbits object) +# +# Reason: The ld invocation is stripping too much +# +# Quoting https://downloads.haskell.org/ghc/latest/docs/html/users_guide/packages.html +# +# > To load a package foo, GHCi can load its libHSfoo.a library directly, but it can also load a package in the form of a single HSfoo.o file that has been pre-linked. Loading the .o file is slightly quicker, but at the expense of having another copy of the compiled package. The rule of thumb is that if the modules of the package were compiled with -split-sections then building the HSfoo.o is worthwhile because it saves time when loading the package into GHCi. Without -split-sections, there is not much difference in load time between the .o and .a libraries, so it is better to save the disk space and only keep the .a around. In a GHC distribution we provide .o files for most packages except the GHC package itself. +# > The HSfoo.o file is built by Cabal automatically; use --disable-library-for-ghci to disable it. To build one manually, the following GNU ld command can be used: + +# > ld -r --whole-archive -o HSfoo.o libHSfoo.a diff --git a/stack.yaml b/stack.yaml index 92b25eb0..5bdc846f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,11 @@ extra-deps: - lsp-test-0.11.0.6 - ghc-check-0.5.0.1 - hie-bios-0.7.1 +- ghc-events-0.13.0 +- ghc-trace-events-0.1.2.1 +- heapsize-0.3.0 +- opentelemetry-0.6.1 +- opentelemetry-extra-0.6.1 # not yet in stackage - Chart-diagrams-1.9.3