diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 1.1.0 + +- The plugin now records much more of the module's compilation. Previously, the + span was only recording the `installCoreToDos` phase. With this version, we + record starting at the very beginning of compilation (before parsing, + TemplateHaskell, etc), and we stop recording at the end of all linking steps. +- GHC support for < 9.6 was dropped. Further patches should restore this + support if desired. +- You can now set `OTEL_GHC_PLUGIN_RECORD_PASSES` to have the plugin report + spans for compilation passes. By default, it will only record the + module-level spans. By setting it to `t` or `true`, it will record the same level of granularity as the prior version. + # 1.0.0 - Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ - add the `opentelemetry-plugin` package as a build dependency of your package -- add `ghc-options: -fplugin OpenTelemetry.Plugin` to your package +- add `ghc-options: -plugin-package opentelemetry-plugin -fplugin OpenTelemetry.Plugin` to your package - configure the appropriate open telemetry environment variables diff --git a/opentelemetry-plugin.cabal b/opentelemetry-plugin.cabal --- a/opentelemetry-plugin.cabal +++ b/opentelemetry-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: opentelemetry-plugin -version: 1.0.0 +version: 1.1.0 synopsis: GHC plugin for open telemetry description: This package provides a GHC plugin that exports each module's build times to an open telemetry collector. See the included `README` below for more details. license: BSD-3-Clause @@ -14,7 +14,7 @@ library hs-source-dirs: src exposed-modules: OpenTelemetry.Plugin - build-depends: base >=4.15.0.0 && < 5 + build-depends: base >=4.18.0.0 && < 5 , bytestring , containers , ghc >= 9.2 && < 9.8 @@ -22,7 +22,10 @@ , hs-opentelemetry-propagator-w3c , hs-opentelemetry-sdk >= 0.0.3.0 && < 0.1 , mwc-random >= 0.13.1.0 + , stm + , stm-containers , text + , transformers , unordered-containers other-modules: OpenTelemetry.Plugin.Shared , Paths_opentelemetry_plugin diff --git a/src/OpenTelemetry/Plugin.hs b/src/OpenTelemetry/Plugin.hs --- a/src/OpenTelemetry/Plugin.hs +++ b/src/OpenTelemetry/Plugin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} {-| This module provides a GHC plugin that will export open telemetry metrics for your build. Specifically, this plugin will create one span per module @@ -16,17 +17,22 @@ import GHC.Types.Target (Target(..), TargetId(..)) import OpenTelemetry.Context (Context) +import GHC.Driver.Pipeline (runPhase) +import GHC.Driver.Pipeline.Phases + ( PhaseHook (..), + TPhase (..), + ) +import GHC.Driver.Hooks (Hooks (..)) import GHC.Plugins ( CoreToDo(..) - , GenModule(..) , HscEnv(..) , Plugin(..) ) -import qualified Control.Monad as Monad import qualified Data.Text as Text import qualified GHC.Plugins as Plugins import qualified GHC.Utils.Outputable as Outputable import qualified OpenTelemetry.Plugin.Shared as Shared +import qualified GHC.Driver.Backend as Backend wrapTodo :: MonadIO io => IO Context -> CoreToDo -> io CoreToDo wrapTodo getParentContext todo = @@ -72,52 +78,88 @@ pure (Plugins.moduleNameString rootModuleName) + let closePhase = + case Backend.backendWritesFiles $ Plugins.backend $ hsc_dflags hscEnv of + False -> + CloseInHscBackend + True -> + CloseInMergeForeign + Shared.setRootModuleNames rootModuleNames Shared.initializeTopLevelContext pure hscEnv - - installCoreToDos _ todos = do - module_ <- Plugins.getModule - - let moduleName_ = moduleName module_ - - let moduleText = Text.pack (Plugins.moduleNameString moduleName_) + { hsc_hooks = + (hsc_hooks hscEnv) + { runPhaseHook = + Just $ PhaseHook \phase -> do + case phase of + T_Hsc _ modSummary -> do + let modName = + Plugins.moduleNameString . Plugins.moduleName . Plugins.ms_mod $ + modSummary + modObjectLocation = + Plugins.ml_obj_file $ Plugins.ms_location modSummary + Shared.recordModuleStart modObjectLocation modName + runPhase phase + T_MergeForeign _pipeEnv _hscEnv objectFilePath _filePaths -> do + -- this phase appears to only be run + -- during compilation, not ghci + x <- runPhase phase + case closePhase of + CloseInMergeForeign -> + Shared.recordModuleEnd objectFilePath + _ -> + pure () + pure x + T_HscBackend _pipeEnv _hscEnv modName _hscSrc _modLoc _hscAction -> do + -- this happens in ghci for sure as + -- a last step + x <- runPhase phase + case closePhase of + CloseInHscBackend -> + Shared.recordModuleEnd (Plugins.moduleNameString modName) + _ -> + pure () + pure x + _ -> do - (getCurrentContext, firstPluginPass, lastPluginPass) <- do - liftIO (Shared.makeWrapperPluginPasses True Shared.getTopLevelContext moduleText) + runPhase phase + } + } - let firstPass = - CoreDoPluginPass "begin module" \modGuts -> liftIO do - firstPluginPass + installCoreToDos _ todos = do + shouldMakeSubPasses <- liftIO Shared.getPluginShouldRecordPasses - pure modGuts + if shouldMakeSubPasses + then do + module_ <- Plugins.getModule - let lastPass = - CoreDoPluginPass "end module" \modGuts -> liftIO do - lastPluginPass + (getCurrentContext, firstPluginPass, lastPluginPass) <- do + let moduleNameString = + Plugins.moduleNameString $ Plugins.moduleName module_ + getContext = + Shared.modifyContextWithParentSpan moduleNameString Shared.getTopLevelContext + liftIO (Shared.makeWrapperPluginPasses True getContext "CoreToDos") - isRoot <- Shared.isRootModule (Plugins.moduleNameString moduleName_) + let firstPass = + CoreDoPluginPass "begin module" \modGuts -> liftIO do + firstPluginPass - -- Flush metrics if we're compiling one of the root - -- modules. This is to work around the fact that we don't - -- have a proper way to finalize the `TracerProvider` - -- (since the finalizer would normally be responsible for - -- flushing any last metrics). - -- - -- You might wonder: why don't we end the top-level span - -- here? Well, we don't know which one of the root modules - -- will be the last one to be compiled. However, flushing - -- once per root module is still fine because flushing is - -- safe to run at any time and in practice there will only - -- be a few root modules. - Monad.when isRoot Shared.flush + pure modGuts - pure modGuts + let lastPass = + CoreDoPluginPass "end module" \modGuts -> liftIO do + lastPluginPass - newTodos <- traverse (wrapTodo getCurrentContext) todos + pure modGuts - pure ([ firstPass ] <> newTodos <> [ lastPass ]) + newTodos <- traverse (wrapTodo getCurrentContext) todos + pure ([ firstPass ] <> newTodos <> [ lastPass ]) + else do + pure todos pluginRecompile = Plugins.purePlugin + +data ClosePhase = CloseInHscBackend | CloseInMergeForeign diff --git a/src/OpenTelemetry/Plugin/Shared.hs b/src/OpenTelemetry/Plugin/Shared.hs --- a/src/OpenTelemetry/Plugin/Shared.hs +++ b/src/OpenTelemetry/Plugin/Shared.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-| This module provides the GHC-API-agnostic logic for this plugin (mostly open telemetry utilities) @@ -8,14 +9,19 @@ under the hood to work within the confines of the plugin API. That means that you should take care to use the utilities in this module correctly in order to avoid the plugin hanging. + + This module is intended to be shared by multiple GHC versions. Please + don't depend on any GHC internal modules. -} module OpenTelemetry.Plugin.Shared ( -- * Plugin passes makeWrapperPluginPasses + , getPluginShouldRecordPasses -- * Top-level context , initializeTopLevelContext , getTopLevelContext + , modifyContextWithParentSpan -- * Root module names , setRootModuleNames @@ -23,10 +29,19 @@ -- * Flushing , flush + , flushMetricsWhenRootModule , getSampler + , tracer + + -- * Recording spans in 'runPhaseHook' + , SpanMap + , newSpanMap + , recordModuleStart + , recordModuleEnd ) where +import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) @@ -36,6 +51,7 @@ import OpenTelemetry.Trace.Sampler (Sampler(..), SamplingResult(..)) import Prelude hiding (span) import System.Random.MWC (GenIO) +import qualified StmContainers.Map as StmMap import OpenTelemetry.Trace ( Attribute(..) @@ -49,8 +65,10 @@ , TracerProviderOptions(..) ) +import qualified Control.Monad as Monad import qualified Control.Concurrent.MVar as MVar import qualified Data.HashMap.Strict as HashMap +import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text.Encoding @@ -67,6 +85,7 @@ import qualified System.IO.Unsafe as Unsafe import qualified System.Random.MWC as MWC import qualified Text.Read as Read +import qualified Control.Concurrent.STM as STM {-| Very large Haskell builds can generate an enormous number of spans, but none of the stock samplers provide a way to sample a subset of @@ -127,7 +146,13 @@ -} tracerProvider :: TracerProvider tracerProvider = Unsafe.unsafePerformIO do - (processors, options) <- Trace.getTracerProviderInitializationOptions + (processors, options) <- + -- This function will collect *all* of the command line arguments + -- that were provided to GHC. This results in a huge amount of data + -- being sent. For that reason, we blank out the process arguments + -- for this section of code. + Environment.withArgs [] do + Trace.getTracerProviderInitializationOptions maybeSampler <- getSampler @@ -165,7 +190,7 @@ :: Bool -- ^ Whether to sample a subset of spans -> IO Context - -- ^ Action to ead the parent span's `Context` + -- ^ Action to read the parent span's `Context` -> Text -- ^ Label for the current span -> IO (IO Context, IO (), IO ()) @@ -212,6 +237,14 @@ topLevelContextMVar = Unsafe.unsafePerformIO MVar.newEmptyMVar {-# NOINLINE topLevelContextMVar #-} +{- | We keep track of the module spans in this top-level 'MVar' so that it + may be shared between the driverPlugin and other plugins. + +-} +topLevelSpanMapMVar :: MVar SpanMap +topLevelSpanMapMVar = Unsafe.unsafePerformIO MVar.newEmptyMVar +{-# NOINLINE topLevelSpanMapMVar #-} + getTopLevelSpan :: IO Span getTopLevelSpan = do traceParent <- lookupEnv "TRACEPARENT" @@ -278,6 +311,8 @@ _ <- MVar.tryPutMVar topLevelContextMVar contextWithSpan + _ <- MVar.tryPutMVar topLevelSpanMapMVar =<< newSpanMap + return () -- | Access the top-level `Context` computed by `initializeTopLevelContext` @@ -326,3 +361,131 @@ _ <- Trace.Core.forceFlushTracerProvider tracerProvider Nothing pure () + +-- | Returns 'True' if the plugin should create spans for module passes in +-- compilation. Examples would be Simplifier, any other plugin execution, +-- etc. +getPluginShouldRecordPasses :: IO Bool +getPluginShouldRecordPasses = do + maybeRecordPasses <- Environment.lookupEnv "OTEL_GHC_PLUGIN_RECORD_PASSES" + pure $ Maybe.fromMaybe False do + recordPasses <- maybeRecordPasses + pure $ Text.toLower (Text.pack recordPasses) `elem` ["true", "t"] + + +-- | Flush metrics if we're compiling one of the root modules. This is to +-- work around the fact that we don't have a proper way to finalize the +-- `TracerProvider` (since the finalizer would normally be responsible for +-- flushing any last metrics). +-- +-- You might wonder: why don't we end the top-level span here? Well, we +-- don't know which one of the root modules will be the last one to be +-- compiled. However, flushing once per root module is still fine because +-- flushing is safe to run at any time and in practice there will only be +-- a few root modules. +flushMetricsWhenRootModule :: String -> IO () +flushMetricsWhenRootModule modName = do + isRoot <- isRootModule modName + Monad.when isRoot flush + +-- | A concurrently accessible map that can be used to connect a module at +-- beginning of compilation and at the end. +-- +-- GHC records the phases of computation in a datatype 'TPhase'. This +-- datatype begins Haskell compilation with the 'T_Hsc' phase. The final +-- phase in compilation is 'T_MergeForeign'. The final phase has a few +-- items: a 'PipeEnv', an 'HscEnv', a 'Filepath' representing the location +-- of the object file for the module, and a list of 'Filepath' that I don't +-- know the purpose of. +-- +-- 'T_Hsc' phase carries a 'ModSummary' type, which fortunately includes +-- a 'ms_location' field which has the 'ml_object_file' field. Since this +-- information is present both at the beginning and end, we can use that to +-- associate a 'Trace.Span' with a module's beginning and end, to record +-- the full time in compilation. +data SpanMap = SpanMap + { fromObjectFile :: StmMap.Map FilePath SpanRelease + , fromModuleName :: StmMap.Map String SpanRelease + } + +-- | A 'Trace.Span' coupled with the action to delete the 'Span' from the +-- 'SpanMap'. +data SpanRelease = SpanRelease + { spanReleaseSpan :: Trace.Span + , spanReleaseAction :: STM.STM () + , spanReleaseModuleName :: String + } + +-- | Create a new empty 'SpanMap'. +newSpanMap :: IO SpanMap +newSpanMap = SpanMap <$> StmMap.newIO <*> StmMap.newIO + +-- | Create a 'Span' for the given 'ModSummary' and record it in the +-- 'SpanMap'. +recordModuleStart + :: FilePath + -- ^ The location of the object file for the module. This should be + -- available through the 'ModSummary' via 'ms_location' and + -- 'ml_obj_file' + -> String + -- ^ A string representing the name of the module. + -> IO () +recordModuleStart modObjectLocation modName = do + spanMap <- MVar.readMVar topLevelSpanMapMVar + context <- getTopLevelContext + span_ <- Trace.createSpan tracer context (Text.pack modName) Trace.defaultSpanArguments + let spanRelease = + SpanRelease + { spanReleaseSpan = + span_ + , spanReleaseAction = do + StmMap.delete modObjectLocation (fromObjectFile spanMap) + StmMap.delete modName (fromModuleName spanMap) + , spanReleaseModuleName = + modName + } + STM.atomically do + StmMap.insert spanRelease modObjectLocation (fromObjectFile spanMap) + StmMap.insert spanRelease modName (fromModuleName spanMap) + +-- | Given a 'Plugins.Module' and a function that provides +-- a 'Trace.Context', this function modifies the 'Trace.Context' to have +-- the parent span of the module. +modifyContextWithParentSpan + :: String + -> IO Context.Context + -> IO Context.Context +modifyContextWithParentSpan module_ getContext = do + mspan <- getSpanForModule module_ + let insertSpan context = + maybe context (`Context.insertSpan` context) mspan + fmap insertSpan getContext + +-- | Retrieve the 'Trace.Span' for a given 'Plugins.Module', if one has +-- been recorded. +getSpanForModule + :: String + -> IO (Maybe Span) +getSpanForModule moduleNameString = do + spanMap <- MVar.readMVar topLevelSpanMapMVar + STM.atomically do + fmap spanReleaseSpan <$> do + StmMap.lookup moduleNameString $ fromModuleName spanMap + +recordModuleEnd + :: String + -- ^ This should be either the module name *or* the object file + -- location. + -> IO () +recordModuleEnd moduleIdentifier = do + spanMap <- MVar.readMVar topLevelSpanMapMVar + mspan <- STM.atomically do + liftA2 + (<|>) + do StmMap.lookup moduleIdentifier (fromObjectFile spanMap) + do StmMap.lookup moduleIdentifier (fromModuleName spanMap) + + Monad.forM_ mspan \SpanRelease {..} -> do + Trace.endSpan spanReleaseSpan Nothing + STM.atomically spanReleaseAction + flushMetricsWhenRootModule spanReleaseModuleName