mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Clean up heapsize bits (#3168)
This commit is contained in:
parent
aee737237c
commit
a13e1b3c8d
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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:
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user