Skip to content

Add an option to control progress reporting #1513

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Mar 9, 2021
Merged

Add an option to control progress reporting #1513

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
e95ca9e
add an option to control progress reporting
pepeiborra Mar 6, 2021
5afb65d
remove redundant imports
pepeiborra Mar 7, 2021
d2b15bc
Tracing: avoid calling actionBracket for no reason
pepeiborra Mar 7, 2021
365e3a6
restore CPP - I have no idea how it got stripped
pepeiborra Mar 7, 2021
0d9df1b
add a comment
pepeiborra Mar 9, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
13 changes: 1 addition & 12 deletions ghcide/src/Development/IDE/Core/FileExists.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand Down
21 changes: 20 additions & 1 deletion ghcide/src/Development/IDE/Core/RuleTypes.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions ghcide/src/Development/IDE/Core/Shake.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
36 changes: 25 additions & 11 deletions ghcide/src/Development/IDE/Core/Tracing.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand All @@ -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
Expand All @@ -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
Expand All @@ -76,17 +86,20 @@ 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)
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

#if MIN_GHC_API_VERSION(8,8,0)
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
Expand Down Expand Up @@ -220,3 +233,4 @@ repeatUntilJust nattempts action = do
case res of
Nothing -> repeatUntilJust (nattempts-1) action
Just{} -> return res

5 changes: 0 additions & 5 deletions ghcide/src/Development/IDE/GHC/ExactPrint.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why did this #if disappear? Seems unrelated.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

doh, again! It's the second time it happens to me, I think this could be a problem with the pre-commit hook, /cc @Ailrun

Copy link
Member

@Ailrun Ailrun Mar 8, 2021 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could be... It's probably because CPP support for the formatter is not so reliable. Unfortunately, I don't know any formatter that works well with CPP...



------------------------------------------------------------------------------
Expand Down
30 changes: 18 additions & 12 deletions ghcide/src/Development/IDE/Types/Options.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
-- SPDX-License-Identifier: Apache-2.0

-- | Options
{-# LANGUAGE RankNTypes #-}
module Development.IDE.Types.Options
( IdeOptions(..)
, IdePreprocessedSource(..)
Expand All @@ -17,27 +18,17 @@ 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)
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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -137,8 +130,21 @@ defaultIdeOptions session = IdeOptions
,optCheckParents = pure CheckOnSaveAndClose
,optHaddockParse = HaddockParse
,optCustomDynFlags = id
,optSkipProgress = defaultSkipProgress
}

defaultSkipProgress :: Typeable a => a -> Bool
defaultSkipProgress key = case () of
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could we comment as to why these nodes get excluded? The original reason for excluding GetFileExists was that given a module Foo.hs, we might have N GetFileExists at each include path, at .lhs, at .hs-boot etc. Whereas every other rule is pretty much only at a single filepath. Is that property true for modtime? It definitely isn't for getfilecontents, but is that about performance?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's performance, but I haven't measured. I'll add a comment or revert to just GetFileExists

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't think is unreasonable - its a commonly called thing that is mostly irrelevant for performance concerns. I do think its important to say that GetFileExists is specially, because its not obvious that is has that weird behaviour, and how if you do include GetFileExists your progress is basically meaningless.

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


-- | The set of options used to locate files belonging to external packages.
data IdePkgLocationOptions = IdePkgLocationOptions
Expand Down