remove manual heap profiling from ghcide

ghcide/exe/Main.hs

@@ -144,7 +144,6 @@ main = withTelemetryLogger $ \telemetryLogger -> do
             let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader
             in defOptions
                 { optShakeProfiling = argsShakeProfiling
-                , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config
                 , optRunSubset = not argsConservativeChangeTracking

ghcide/ghcide.cabal

@@ -95,7 +95,6 @@ library
         Diff ^>=0.4.0,
         vector,
         opentelemetry >=0.6.1,
-        heapsize ==0.3.*,
         unliftio >= 0.2.6,
         unliftio-core,
         ghc-boot-th,

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

@@ -1,6 +1,7 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE CPP                       #-}
 {-# LANGUAGE ConstraintKinds           #-}
 {-# LANGUAGE DerivingStrategies        #-}
 {-# LANGUAGE DuplicateRecordFields     #-}
@@ -10,7 +11,6 @@
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE RecursiveDo               #-}
 {-# LANGUAGE TypeFamilies              #-}
-{-# LANGUAGE CPP                       #-}
 
 -- | A Shake implementation of the compiler service.
 --
@@ -162,7 +162,7 @@ import           GHC.Stack                              (HasCallStack)
 import           HieDb.Types
 import           Ide.Plugin.Config
 import qualified Ide.PluginUtils                        as HLS
-import           Ide.Types                              (PluginId, IdePlugins)
+import           Ide.Types                              (IdePlugins, PluginId)
 import           Language.LSP.Diagnostics
 import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.Types
@@ -630,13 +630,10 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
     shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir
 
     IdeOptions
-        { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled
-        , optProgressStyle
+        { optProgressStyle
         , optCheckParents
         } <- getIdeOptionsIO shakeExtras
 
-    startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras
-
     checkParents <- optCheckParents
 
     -- monitoring

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

@@ -5,9 +5,6 @@
 module Development.IDE.Core.Tracing
     ( otTracedHandler
     , otTracedAction
-    , startProfilingTelemetry
-    , measureMemory
-    , getInstrumentCached
     , otTracedProvider
     , otSetUri
     , otTracedGarbageCollection
@@ -17,56 +14,28 @@ module Development.IDE.Core.Tracing
     )
 where
 
-import           Control.Concurrent.Async          (Async, async)
-import           Control.Concurrent.Extra          (modifyVar_, newVar, readVar,
-                                                    threadDelay)
-import           Control.Exception                 (evaluate)
-import           Control.Exception.Safe            (SomeException, catch,
-                                                    generalBracket)
-import           Control.Monad                     (forM_, forever, void, when,
-                                                    (>=>))
+import           Control.Exception.Safe            (generalBracket)
 import           Control.Monad.Catch               (ExitCase (..), MonadMask)
-import           Control.Monad.Extra               (whenJust)
 import           Control.Monad.IO.Unlift
-import           Control.Monad.STM                 (atomically)
-import           Control.Seq                       (r0, seqList, seqTuple2,
-                                                    using)
 import           Data.ByteString                   (ByteString)
 import           Data.ByteString.Char8             (pack)
-import qualified Data.HashMap.Strict               as HMap
-import           Data.IORef                        (modifyIORef', newIORef,
-                                                    readIORef, writeIORef)
 import           Data.String                       (IsString (fromString))
 import qualified Data.Text                         as T
 import           Data.Text.Encoding                (encodeUtf8)
-import           Data.Typeable                     (TypeRep, typeOf)
 import           Data.Word                         (Word16)
 import           Debug.Trace.Flags                 (userTracingEnabled)
-import           Development.IDE.Core.RuleTypes    (GhcSession (GhcSession),
-                                                    GhcSessionDeps (GhcSessionDeps),
-                                                    GhcSessionIO (GhcSessionIO))
 import           Development.IDE.Graph             (Action)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Diagnostics (FileDiagnostic,
                                                     showDiagnostics)
 import           Development.IDE.Types.Location    (Uri (..))
-import           Development.IDE.Types.Logger      (Logger (Logger), logDebug,
-                                                    logInfo)
-import           Development.IDE.Types.Shake       (ValueWithDiagnostics (..),
-                                                    Values, fromKeyType)
-import           Foreign.Storable                  (Storable (sizeOf))
-import           HeapSize                          (recursiveSize, runHeapsize)
-import           Ide.PluginUtils                   (installSigUsr1Handler)
+import           Development.IDE.Types.Logger      (Logger (Logger))
 import           Ide.Types                         (PluginId (..))
 import           Language.LSP.Types                (NormalizedFilePath,
                                                     fromNormalizedFilePath)
-import qualified "list-t" ListT
-import           Numeric.Natural                   (Natural)
 import           OpenTelemetry.Eventlog            (SpanInFlight (..), addEvent,
-                                                    beginSpan, endSpan,
-                                                    mkValueObserver, observe,
-                                                    setTag, withSpan, withSpan_)
-import qualified StmContainers.Map                 as STM
+                                                    beginSpan, endSpan, setTag,
+                                                    withSpan)
 
 #if MIN_VERSION_ghc(8,8,0)
 otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
@@ -178,126 +147,3 @@ otTracedProvider (PluginId pluginName) provider act
   | otherwise = act
 
 
-startProfilingTelemetry :: Bool -> Logger -> Values -> IO ()
-startProfilingTelemetry allTheTime logger state = do
-    instrumentFor <- getInstrumentCached
-
-    installSigUsr1Handler $ do
-        logInfo logger "SIGUSR1 received: performing memory measurement"
-        performMeasurement logger state instrumentFor
-
-    when allTheTime $ void $ regularly (1 * seconds) $
-        performMeasurement logger state instrumentFor
-  where
-        seconds = 1000000
-
-        regularly :: Int -> IO () -> IO (Async ())
-        regularly delay act = async $ forever (act >> threadDelay delay)
-
-
-performMeasurement ::
-  Logger ->
-  Values ->
-  (Maybe String -> IO OurValueObserver) ->
-  IO ()
-performMeasurement logger values instrumentFor = do
-    contents <- atomically $ ListT.toList $ STM.listT values
-    let keys = typeOf GhcSession
-             : typeOf GhcSessionDeps
-             -- TODO restore
-             : [ kty
-                | (k,_) <- contents
-                , Just (kty,_) <- [fromKeyType k]
-                -- do GhcSessionIO last since it closes over stateRef itself
-                , kty /= typeOf GhcSession
-                , kty /= typeOf GhcSessionDeps
-                , kty /= typeOf GhcSessionIO
-             ]
-             ++ [typeOf GhcSessionIO]
-    groupedForSharing <- evaluate (keys `using` seqList r0)
-    measureMemory logger [groupedForSharing] instrumentFor values
-        `catch` \(e::SomeException) ->
-        logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e))
-
-
-type OurValueObserver = Int -> IO ()
-
-getInstrumentCached :: IO (Maybe String -> 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
-    -> [[TypeRep]]     -- ^ Grouping of keys for the sharing-aware analysis
-    -> (Maybe String -> IO OurValueObserver)
-    -> Values
-    -> IO ()
-measureMemory logger groups instrumentFor values = withSpan_ "Measure Memory" $ do
-    contents <- atomically $ ListT.toList $ STM.listT values
-    valuesSizeRef <- newIORef $ Just 0
-    let !groupsOfGroupedValues = groupValues contents
-    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 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 -> [ [(String, [Value Dynamic])] ]
-        groupValues contents =
-            let !groupedValues =
-                    [ [ (show ty, vv)
-                      | ty <- groupKeys
-                      , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- contents
-                                     , kty == ty]
-                      ]
-                    | 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
-

ghcide/src/Development/IDE/Main.hs

@@ -64,7 +64,6 @@ import           Development.IDE.Core.Shake               (IdeState (shakeExtras
                                                            shakeSessionInit,
                                                            uses)
 import qualified Development.IDE.Core.Shake               as Shake
-import           Development.IDE.Core.Tracing             (measureMemory)
 import           Development.IDE.Graph                    (action)
 import           Development.IDE.LSP.LanguageServer       (runLanguageServer,
                                                            setupLSP)
@@ -234,7 +233,6 @@ commandP plugins =
 
 data Arguments = Arguments
     { argsProjectRoot           :: Maybe FilePath
-    , argsOTMemoryProfiling     :: Bool
     , argCommand                :: Command
     , argsLogger                :: IO Logger
     , argsRules                 :: Rules ()
@@ -255,7 +253,6 @@ data Arguments = Arguments
 defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments
 defaultArguments recorder logger = Arguments
         { argsProjectRoot = Nothing
-        , argsOTMemoryProfiling = False
         , argCommand = LSP
         , argsLogger = pure logger
         , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick
@@ -439,21 +436,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             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 values = state $ shakeExtras ide
-                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)
-
-                stateContents <- atomically $ ListT.toList $ STM.listT values
-                printf "# Shake value store contents(%d):\n" (length stateContents)
-                let keys =
-                        nub $
-                            typeOf GhcSession :
-                            typeOf GhcSessionDeps :
-                            [kty | (fromKeyType -> Just (kty,_), _) <- stateContents, kty /= typeOf GhcSessionIO] ++
-                            [typeOf GhcSessionIO]
-                measureMemory logger [keys] consoleObserver values
-
             unless (null failed) (exitWith $ ExitFailure (length failed))
         Db opts cmd -> do
             root <-  maybe IO.getCurrentDirectory return argsProjectRoot

ghcide/src/Development/IDE/Types/Options.hs

@@ -43,9 +43,6 @@ data IdeOptions = IdeOptions
     -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)
   , 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
@@ -123,7 +120,6 @@ defaultIdeOptions session = IdeOptions
     ,optPkgLocationOpts = defaultIdePkgLocationOptions
     ,optShakeOptions = shakeOptions
     ,optShakeProfiling = Nothing
-    ,optOTMemoryProfiling = IdeOTMemoryProfiling False
     ,optReportProgress = IdeReportProgress False
     ,optLanguageSyntax = "haskell"
     ,optNewColonConvention = False

stack-lts16.yaml

@@ -57,7 +57,6 @@ extra-deps:
   - ghc-source-gen-0.4.1.0
   - ghc-trace-events-0.1.2.1
   - haskell-src-exts-1.21.1
-  - heapsize-0.3.0
   - hlint-3.2.8
   - HsYAML-aeson-0.2.0.0@rev:2
   - hoogle-5.0.17.11

stack-lts19.yaml

@@ -45,7 +45,6 @@ extra-deps:
 - ghc-lib-9.2.4.20220729
 - ghc-lib-parser-9.2.4.20220729
 - ghc-lib-parser-ex-9.2.0.4
-- heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417
 - hiedb-0.4.2.0
 - hlint-3.4
 - implicit-hie-0.1.2.7@sha256:82bbbb1a8c05f99c8af3c16ac53e80c8648d8bf047b25ed5ce45a135bd736907,3122
@@ -66,8 +65,6 @@ configure-options:
       - --disable-library-for-ghci
   haskell-language-server:
       - --disable-library-for-ghci
-  heapsize:
-      - --disable-library-for-ghci
 
 flags:
   haskell-language-server:

stack.yaml

@@ -37,7 +37,6 @@ packages:
 
 extra-deps:
 - floskell-0.10.6@sha256:e77d194189e8540abe2ace2c7cb8efafc747ca35881a2fefcbd2d40a1292e036,3819
-- heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417
 - hiedb-0.4.2.0
 - implicit-hie-0.1.2.7@sha256:82bbbb1a8c05f99c8af3c16ac53e80c8648d8bf047b25ed5ce45a135bd736907,3122
 - implicit-hie-cradle-0.5.0.0@sha256:4276f60f3a59bc22df03fd918f73bca9f777de9568f85e3a8be8bd7566234a59,2368