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 <pepeiborra@me.com>

* [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 <m.pardalos@gmail.com>
Co-authored-by: Michalis Pardalos <mpardalos@gmail.com>
Co-authored-by: Guru Devanla <gdevanla@users.noreply.github.com>
Co-authored-by: Samuel Ainsworth <skainsworth@gmail.com>

.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

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,
+          "-S" <> gcStats name
-          "-RTS"
         ]
+          ++ 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 =

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],

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 (`<pkgname>-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
+   ```

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

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
+                    { optReportProgress    = clientSupportsProgress caps
-                    , optShakeProfiling = argsShakeProfiling
+                    , optShakeProfiling    = argsShakeProfiling
-                    , optTesting        = IdeTesting argsTesting
+                    , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                    , optThreads        = argsThreads
+                    , optTesting           = IdeTesting argsTesting
-                    , optCheckParents   = checkParents config
+                    , optThreads           = argsThreads
-                    , optCheckProject   = checkProject config
+                    , 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
+        let dummyWithProg _ _ f = f (const (pure ()))
-            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"
+        let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
-        putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
+        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

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,

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
   '';
 }

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

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

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

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
+        workRun restore = withSpan "Shake session" $ \otSpan -> do
-          let acts' = pumpActionThread : map run (reenqueued ++ acts)
+          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

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

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 withNotification old f = Just $ \r@NotificationMessage{_method} ->
-    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
+            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" ++

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

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 IdeReportProgress    = IdeReportProgress Bool
-newtype IdeDefer          = IdeDefer          Bool
+newtype IdeDefer             = IdeDefer          Bool
-newtype IdeTesting        = IdeTesting        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

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)

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

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