Trace rebuilds (#2283)

* trace interface regeneration events

* trace recordDirtyKeys calls

* fix 8.6 build

* remove userTracingEnabled check

as pointed out by @michaelpj the check is already installed in withTracing

the logger should not make any assumptions regarding user tracing being static anyway

Author: pepeiborra

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

@@ -102,6 +102,7 @@ import           Data.Functor
 import qualified Data.HashMap.Strict               as HashMap
 import           Data.Tuple.Extra                  (dupe)
 import           Data.Unique                       as Unique
+import           Development.IDE.Core.Tracing      (withTrace)
 import qualified Language.LSP.Server               as LSP
 import qualified Language.LSP.Types                as LSP
 
@@ -899,7 +900,8 @@ loadHieFile ncu f = do
 --   Assumes file exists.
 --   Requires the 'HscEnv' to be set up with dependencies
 loadInterface
-  :: MonadIO m => HscEnv
+  :: (MonadIO m, MonadMask m)
+  => HscEnv
   -> ModSummary
   -> SourceModified
   -> Maybe LinkableType
@@ -939,7 +941,15 @@ loadInterface session ms sourceMod linkableNeeded regen = do
                hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable
                return ([], Just $ mkHiFileResult ms hmi)
              else regen linkableNeeded
-          (_reason, _) -> regen linkableNeeded
+          (_reason, _) -> withTrace "regenerate interface" $ \setTag -> do
+                 setTag "Module" $ moduleNameString $ moduleName $ ms_mod ms
+                 setTag "Reason" $ showReason _reason
+                 regen linkableNeeded
+
+showReason :: RecompileRequired -> String
+showReason UpToDate          = "UpToDate"
+showReason MustCompile       = "MustCompile"
+showReason (RecompBecause s) = s
 
 mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
 mkDetailsFromIface session iface linkable = do

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

@@ -439,8 +439,10 @@ recordDirtyKeys
   -> k
   -> [NormalizedFilePath]
   -> IO ()
-recordDirtyKeys ShakeExtras{dirtyKeys} key file =
+recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do
     atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
+    addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file)
+
 
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues ::

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

@@ -8,7 +8,8 @@ module Development.IDE.Core.Tracing
     , getInstrumentCached
     , otTracedProvider
     , otSetUri
-    )
+    , withTrace
+    ,withEventTrace)
 where
 
 import           Control.Concurrent.Async       (Async, async)
@@ -19,13 +20,11 @@ import           Control.Exception.Safe         (SomeException, catch,
                                                  generalBracket)
 import           Control.Monad                  (forM_, forever, void, when,
                                                  (>=>))
-import           Control.Monad.Catch            (ExitCase (..))
+import           Control.Monad.Catch            (ExitCase (..), MonadMask)
 import           Control.Monad.Extra            (whenJust)
 import           Control.Monad.IO.Unlift
 import           Control.Seq                    (r0, seqList, seqTuple2, using)
-#if MIN_VERSION_ghc(8,8,0)
 import           Data.ByteString                (ByteString)
-#endif
 import           Data.ByteString.Char8          (pack)
 import           Data.Dynamic                   (Dynamic)
 import qualified Data.HashMap.Strict            as HMap
@@ -57,6 +56,26 @@ import           OpenTelemetry.Eventlog         (Instrument, SpanInFlight (..),
                                                  mkValueObserver, observe,
                                                  setTag, withSpan, withSpan_)
 
+withTrace :: (MonadMask m, MonadIO m) =>
+    String -> ((String -> String -> m ()) -> m a) -> m a
+withTrace name act
+  | userTracingEnabled
+  = withSpan (fromString name) $ \sp -> do
+      let setSpan' k v = setTag sp (fromString k) (fromString v)
+      act setSpan'
+  | otherwise = act (\_ _ -> pure ())
+
+#if MIN_VERSION_ghc(8,8,0)
+withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a
+#else
+withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a
+#endif
+withEventTrace name act
+  | userTracingEnabled
+  = withSpan (fromString name) $ \sp -> do
+      act (addEvent sp)
+  | otherwise = act (\_ _ -> pure ())
+
 -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
 otTracedHandler
     :: MonadUnliftIO m

ghcide/src/Development/IDE/Main.hs

@@ -30,7 +30,6 @@ import qualified Data.Text.IO                          as T
 import           Data.Text.Lazy.Encoding               (decodeUtf8)
 import qualified Data.Text.Lazy.IO                     as LT
 import           Data.Word                             (Word16)
-import           Debug.Trace.Flags                     (userTracingEnabled)
 import           Development.IDE                       (Action, GhcVersion (..),
                                                         Priority (Debug), Rules,
                                                         ghcVersion,
@@ -55,7 +54,8 @@ import           Development.IDE.Core.Service          (initialise, runAction)
 import           Development.IDE.Core.Shake            (IdeState (shakeExtras),
                                                         ShakeExtras (state),
                                                         shakeSessionInit, uses)
-import           Development.IDE.Core.Tracing          (measureMemory)
+import           Development.IDE.Core.Tracing          (measureMemory,
+                                                        withEventTrace)
 import           Development.IDE.Graph                 (action)
 import           Development.IDE.LSP.LanguageServer    (runLanguageServer)
 import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
@@ -101,7 +101,6 @@ import           Ide.Types                             (IdeCommand (IdeCommand),
                                                         ipMap)
 import qualified Language.LSP.Server                   as LSP
 import           Numeric.Natural                       (Natural)
-import           OpenTelemetry.Eventlog                (addEvent, withSpan)
 import           Options.Applicative                   hiding (action)
 import qualified System.Directory.Extra                as IO
 import           System.Exit                           (ExitCode (ExitFailure),
@@ -189,7 +188,7 @@ defaultArguments :: Priority -> Arguments
 defaultArguments priority = Arguments
         { argsOTMemoryProfiling = False
         , argCommand = LSP
-        , argsLogger = stderrLogger priority <> telemetryLogger
+        , argsLogger = stderrLogger priority <> pure telemetryLogger
         , argsRules = mainRule >> action kick
         , argsGhcidePlugin = mempty
         , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
@@ -236,12 +235,10 @@ stderrLogger logLevel = do
     return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $
         T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m
 
-telemetryLogger :: IO Logger
-telemetryLogger
-    | userTracingEnabled = return $ Logger $ \p m ->
-        withSpan "log" $ \sp ->
-            addEvent sp (fromString $ "Log " <> show p) (encodeUtf8 $ trim m)
-    | otherwise = mempty
+telemetryLogger :: Logger
+telemetryLogger = Logger $ \p m ->
+        withEventTrace "Log" $ \addEvent ->
+            addEvent (fromString $ "Log " <> show p) (encodeUtf8 $ trim m)
     where
         -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
         trim = T.take (fromIntegral(maxBound :: Word16) - 10)