From e95ca9ed0afd57332f842fa5e43f1fd26c1913fe Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Mar 2021 23:51:00 +0000 Subject: [PATCH 1/5] add an option to control progress reporting --- ghcide/src/Development/IDE/Core/FileExists.hs | 13 +--------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 21 +++++++++++++++- ghcide/src/Development/IDE/Core/Shake.hs | 4 +-- ghcide/src/Development/IDE/Types/Options.hs | 25 ++++++++++--------- 4 files changed, 36 insertions(+), 27 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index ee068c36b9..e37e4603b9 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -13,19 +13,17 @@ where import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra -import Data.Binary import qualified Data.ByteString as BS import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Development.IDE.Core.FileStore import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Options import Development.Shake -import Development.Shake.Classes -import GHC.Generics import Language.LSP.Server hiding (getVirtualFile) import Language.LSP.Types import Language.LSP.Types.Capabilities @@ -112,15 +110,6 @@ fromChange FcChanged = Nothing ------------------------------------------------------------------------------------- -type instance RuleResult GetFileExists = Bool - -data GetFileExists = GetFileExists - deriving (Eq, Show, Typeable, Generic) - -instance NFData GetFileExists -instance Hashable GetFileExists -instance Binary GetFileExists - -- | Returns True if the file exists -- Note that a file is not considered to exist unless it is saved to disk. -- In particular, VFS existence is not enough. diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index f557cb63bf..d845bacc0e 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -43,7 +43,7 @@ import Data.Text (Text) import Development.IDE.Import.FindImports (ArtifactsLocation) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings -import Development.IDE.Types.Options (IdeGhcSession) +import Development.IDE.Types.Diagnostics import Fingerprint import GHC.Serialized (Serialized) import Language.LSP.Types (NormalizedFilePath) @@ -254,6 +254,9 @@ type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe Text) +type instance RuleResult GetFileExists = Bool + + -- The Shake key type for getModificationTime queries newtype GetModificationTime = GetModificationTime_ { missingFileDiagnostics :: Bool @@ -299,6 +302,12 @@ instance Hashable GetFileContents instance NFData GetFileContents instance Binary GetFileContents +data GetFileExists = GetFileExists + deriving (Eq, Show, Typeable, Generic) + +instance NFData GetFileExists +instance Hashable GetFileExists +instance Binary GetFileExists data FileOfInterestStatus = OnDisk @@ -478,6 +487,16 @@ type instance RuleResult GetClientSettings = Hashed (Maybe Value) -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 type instance RuleResult GhcSessionIO = IdeGhcSession +data IdeGhcSession = IdeGhcSession + { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + -- ^ Returns the Ghc session and the cradle dependencies + , sessionVersion :: !Int + -- ^ Used as Shake key, versions must be unique and not reused + } + +instance Show IdeGhcSession where show _ = "IdeGhcSession" +instance NFData IdeGhcSession where rnf !_ = () + data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1b7c30e4c1..effc31bf8e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -939,8 +939,8 @@ defineEarlyCutoff' -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics key file old mode action = 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 + options <- getIdeOptions + (if optSkipProgress options key then id else withProgressVar inProgress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do v <- liftIO $ getValues state key file diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 24e96a7435..c35df67288 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options +{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..) @@ -17,10 +18,10 @@ module Development.IDE.Types.Options , OptHaddockParse(..) ,optShakeFiles) where -import Control.DeepSeq (NFData (..)) import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.RuleTypes import Development.IDE.Types.Diagnostics -import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.Shake import GHC hiding (parseModule, typecheckModule) @@ -28,16 +29,6 @@ import GhcPlugins as GHC hiding (fst3, (<>)) import Ide.Plugin.Config import qualified Language.LSP.Types.Capabilities as LSP -data IdeGhcSession = IdeGhcSession - { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - -- ^ Returns the Ghc session and the cradle dependencies - , sessionVersion :: !Int - -- ^ Used as Shake key, versions must be unique and not reused - } - -instance Show IdeGhcSession where show _ = "IdeGhcSession" -instance NFData IdeGhcSession where rnf !_ = () - data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings @@ -85,6 +76,8 @@ data IdeOptions = IdeOptions -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used , optShakeOptions :: ShakeOptions + , optSkipProgress :: forall a. Typeable a => a -> Bool + -- ^ Predicate to select which rule keys to exclude from progress reporting. } optShakeFiles :: IdeOptions -> Maybe FilePath @@ -137,8 +130,16 @@ defaultIdeOptions session = IdeOptions ,optCheckParents = pure CheckOnSaveAndClose ,optHaddockParse = HaddockParse ,optCustomDynFlags = id + ,optSkipProgress = defaultSkipProgress } +defaultSkipProgress :: Typeable a => a -> Bool +defaultSkipProgress key = case () of + _ | Just GetFileContents <- cast key -> True + _ | Just GetFileExists <- cast key -> True + _ | Just GetModificationTime_{} <- cast key -> True + _ -> False + -- | The set of options used to locate files belonging to external packages. data IdePkgLocationOptions = IdePkgLocationOptions From 5afb65d3358ecc1d42ac2eb321584501d5792b2a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Mar 2021 13:35:25 +0000 Subject: [PATCH 2/5] remove redundant imports --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 9f3280e86c..3688f80a82 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -67,11 +67,6 @@ import Data.Monoid (All(All)) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow #endif -#if __GLASGOW_HASKELL__ > 808 -import Bag (listToBag) -import ErrUtils (mkErrMsg) -import Outputable (text, neverQualify) -#endif ------------------------------------------------------------------------------ From d2b15bc1ee00fe17232714741cad2b56c7023e5c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Mar 2021 13:43:44 +0000 Subject: [PATCH 3/5] Tracing: avoid calling actionBracket for no reason --- ghcide/src/Development/IDE/Core/Tracing.hs | 46 ++++++++++++++-------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index d9caffec82..e82a7ee856 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -36,6 +36,7 @@ import Development.IDE.Types.Shake (Key (..), Value, Values) import Development.Shake (Action, actionBracket) import Foreign.Storable (Storable (sizeOf)) +import GHC.RTS.Flags import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler) import Ide.Types (PluginId (..)) @@ -47,6 +48,7 @@ import OpenTelemetry.Eventlog (Instrument, SpanInFlight, addEvent, beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) +import System.IO.Unsafe (unsafePerformIO) -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler @@ -68,6 +70,14 @@ otTracedHandler requestType label act = otSetUri :: SpanInFlight -> Uri -> IO () otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) +{-# NOINLINE isTracingEnabled #-} +isTracingEnabled :: Bool +isTracingEnabled = unsafePerformIO $ do + flags <- getTraceFlags + case tracing flags of + TraceNone -> return False + _ -> return True + -- | Trace a Shake action using opentelemetry. otTracedAction :: Show k @@ -76,23 +86,26 @@ otTracedAction -> (a -> Bool) -- ^ Did this action succeed? -> Action a -- ^ The action -> Action a -otTracedAction key file success act = actionBracket - (do - sp <- beginSpan (fromString (show key)) - setTag sp "File" (fromString $ fromNormalizedFilePath file) - return sp - ) - endSpan - (\sp -> do - res <- act - unless (success res) $ setTag sp "error" "1" - return res) - -#if MIN_GHC_API_VERSION(8,8,0) +otTracedAction key file success act + | isTracingEnabled = + actionBracket + (do + sp <- beginSpan (fromString (show key)) + setTag sp "File" (fromString $ fromNormalizedFilePath file) + return sp + ) + endSpan + (\sp -> do + res <- act + unless (success res) $ setTag sp "error" "1" + return res) + | otherwise = act + + otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -#endif + + + otTracedProvider (PluginId pluginName) provider act = do runInIO <- askRunInIO liftIO $ withSpan (provider <> " provider") $ \sp -> do @@ -220,3 +233,4 @@ repeatUntilJust nattempts action = do case res of Nothing -> repeatUntilJust (nattempts-1) action Just{} -> return res + From 365e3a6679c2a2712994db595aae09df1beaf385 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 7 Mar 2021 14:19:24 +0000 Subject: [PATCH 4/5] restore CPP - I have no idea how it got stripped --- ghcide/src/Development/IDE/Core/Tracing.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index e82a7ee856..b970ba7603 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -101,11 +101,11 @@ otTracedAction key file success act return res) | otherwise = act - +#if MIN_GHC_API_VERSION(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a - - - +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +#endif otTracedProvider (PluginId pluginName) provider act = do runInIO <- askRunInIO liftIO $ withSpan (provider <> " provider") $ \sp -> do From 0d9df1bf9384d7dc43908266e4fee1ab1d7e8bd0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 9 Mar 2021 08:45:52 +0000 Subject: [PATCH 5/5] add a comment --- ghcide/src/Development/IDE/Types/Options.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index c35df67288..c09bd4a40b 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -135,8 +135,13 @@ defaultIdeOptions session = IdeOptions defaultSkipProgress :: Typeable a => a -> Bool defaultSkipProgress key = case () of + -- don't do progress for GetFileContents as it's cheap _ | Just GetFileContents <- cast key -> True + -- don't do progress for GetFileExists, as there are lots of redundant nodes + -- (normally there is one node per file, but this is not the case for GetFileExists) _ | Just GetFileExists <- cast key -> True + -- don't do progress for GetModificationTime as there are lot of redundant nodes + -- (for the interface files) _ | Just GetModificationTime_{} <- cast key -> True _ -> False