diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.5.0.0 + +- **BREAKING**: Put `ghc-debug-stub` support behind `use-ghc-debug-stub` feature flag. + ### 0.4.0.0 - Fix space leak in `processHeapProfSampleData`. diff --git a/eventlog-live-otelcol.cabal b/eventlog-live-otelcol.cabal --- a/eventlog-live-otelcol.cabal +++ b/eventlog-live-otelcol.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventlog-live-otelcol -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Stream eventlog data to the OpenTelemetry Collector. description: This executable supports live streaming of eventlog data into @@ -88,6 +88,15 @@ location: https://github.com/well-typed/eventlog-live.git subdir: eventlog-live-otelcol +-- 2025-11-10: +-- This flag should enable switching the use of ghc-debug-stub on +-- and off, since it may cause issues with certain versions of GHC. +-- See https://github.com/well-typed/eventlog-live/issues/88 +flag use-ghc-debug-stub + description: Use ghc-debug-stub + default: False + manual: True + -- 2025-11-06: -- This flag should enable switching between template-haskell and -- template-haskell-lift, because the latter is not on nixpkgs. @@ -145,6 +154,7 @@ GHC.Eventlog.Live.Otelcol.Stats other-modules: + GHC.Debug.Stub.Compat GHC.Eventlog.Live.Otelcol.Config.Default GHC.Eventlog.Live.Otelcol.Config.Default.Raw GHC.Eventlog.Live.Otelcol.Config.Types @@ -164,7 +174,6 @@ , eventlog-live >=0.4 && <0.5 , eventlog-socket >=0.1.0 && <0.2 , file-embed >=0.0.16 && <0.1 - , ghc-debug-stub >=0.1 && <1.0 , ghc-events >=0.20 && <0.21 , grapesy >=1.0.0 && <1.2 , hashable >=1.4 && <1.6 @@ -180,6 +189,10 @@ , unordered-containers >=0.2.20 && <0.3 , vector >=0.11 && <0.14 , yaml >=0.11 && <0.12 + + if flag(use-ghc-debug-stub) + build-depends: ghc-debug-stub >=0.1 && <1.0 + cpp-options: -DEVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB if flag(use-template-haskell-lift) build-depends: template-haskell-lift >=0.1 && <0.2 diff --git a/src/GHC/Debug/Stub/Compat.hs b/src/GHC/Debug/Stub/Compat.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Stub/Compat.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : GHC.Debug.Stub.Compat +Description : The implementation of @eventlog-live-otelcol@. +Stability : experimental +Portability : portable +-} +module GHC.Debug.Stub.Compat ( + MyGhcDebugSocket (..), + withMyGhcDebug, + maybeMyGhcDebugSocketParser, +) where + +import Control.Applicative (asum) +import Data.Text qualified as T (pack) +import GHC.Eventlog.Live.Logger (logError) +import GHC.Eventlog.Live.Verbosity (Verbosity) +import Options.Applicative qualified as O + +#if defined(EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB) +import GHC.Debug.Stub qualified as GHC.Debug (withGhcDebug, withGhcDebugTCP, withGhcDebugUnix) +import System.Exit (exitFailure) +import Text.Read (readEither) +#else +import Data.Maybe (isJust) +import System.Exit (exitFailure) +import Options.Applicative.Help.Pretty qualified as OP +#endif + +-------------------------------------------------------------------------------- +-- My GHC Debug + +data MyGhcDebugSocket + = MyGhcDebugSocketDefault + | MyGhcDebugSocketUnix FilePath + | MyGhcDebugSocketTcp String + deriving (Show) + +{- | +Internal helper. +Start @ghc-debug@ on the given `MyGhcDebugSocket`. +-} +withMyGhcDebug :: Verbosity -> Maybe MyGhcDebugSocket -> IO a -> IO a +#if defined(EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB) +withMyGhcDebug verbosity maybeMyGhcDebugSocket action = + case maybeMyGhcDebugSocket of + Nothing -> action + Just MyGhcDebugSocketDefault -> + GHC.Debug.withGhcDebug action + Just (MyGhcDebugSocketUnix myGhcDebugSocketUnix) -> + GHC.Debug.withGhcDebugUnix myGhcDebugSocketUnix action + Just (MyGhcDebugSocketTcp myGhcDebugSocketTcp) -> do + let (host, port) = break (== ':') myGhcDebugSocketTcp + case readEither port of + Left _parseError -> do + logError verbosity . T.pack $ + "Could not parse ghc-debug TCP address " <> myGhcDebugSocketTcp <> "." + exitFailure + Right portWord16 -> + GHC.Debug.withGhcDebugTCP host portWord16 action +#else +withMyGhcDebug verbosity maybeMyGhcDebugSocket action + | isJust maybeMyGhcDebugSocket = do + logError verbosity $ T.pack myGhcDebugSocketUnsupportedErrorMessage + exitFailure + | otherwise = action +#endif + +-------------------------------------------------------------------------------- +-- My GHC Debug + +maybeMyGhcDebugSocketParser :: O.Parser (Maybe MyGhcDebugSocket) +#if defined(EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB) +maybeMyGhcDebugSocketParser = + O.optional . asum $ + [ myGhcDebugSocketDefaultParser + , myGhcDebugSocketUnixParser + , myGhcDebugSocketTcpParser + ] + where + myGhcDebugSocketDefaultParser = + O.flag' + MyGhcDebugSocketDefault + ( O.long myGhcDebugSocketDefaultLong + <> O.help myGhcDebugSocketDefaultHelp + ) + myGhcDebugSocketUnixParser = + MyGhcDebugSocketUnix + <$> O.strOption + ( O.long myGhcDebugSocketUnixLong + <> O.metavar myGhcDebugSocketUnixMetavar + <> O.help myGhcDebugSocketUnixHelp + ) + myGhcDebugSocketTcpParser = + MyGhcDebugSocketUnix + <$> O.strOption + ( O.long myGhcDebugSocketTcpLong + <> O.metavar myGhcDebugSocketTcpMetavar + <> O.help myGhcDebugSocketTcpHelp + ) +#else +maybeMyGhcDebugSocketParser = + asum . fmap mkUnsupportedParser $ + [ myGhcDebugSocketDefaultMod + , myGhcDebugSocketUnixMod + , myGhcDebugSocketTcpMod + ] + where + mkUnsupportedParser modOptionFields = + Nothing <$ O.infoOption myGhcDebugSocketUnsupportedErrorMessage modOptionFields + mkUnsupportedHelpDoc help = + Just $ OP.vcat [OP.pretty $ "Unsupported. Requires build with -f+" <> myGhcDebugFeatureFlag <> ".", OP.pretty help] + myGhcDebugSocketDefaultMod = + O.long myGhcDebugSocketDefaultLong + <> O.hidden + <> O.helpDoc (mkUnsupportedHelpDoc myGhcDebugSocketDefaultHelp) + myGhcDebugSocketUnixMod = + O.long myGhcDebugSocketUnixLong + <> O.metavar myGhcDebugSocketUnixMetavar + <> O.hidden + <> O.helpDoc (mkUnsupportedHelpDoc myGhcDebugSocketUnixHelp) + myGhcDebugSocketTcpMod = + O.long myGhcDebugSocketTcpLong + <> O.metavar myGhcDebugSocketTcpMetavar + <> O.hidden + <> O.helpDoc (mkUnsupportedHelpDoc myGhcDebugSocketTcpHelp) +#endif + +#if !defined(EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB) +myGhcDebugFeatureFlag :: String +myGhcDebugFeatureFlag = + "use-ghc-debug-stub" +#endif + +#if !defined(EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB) +myGhcDebugSocketUnsupportedErrorMessage :: String +myGhcDebugSocketUnsupportedErrorMessage = + "Cannot open ghc-debug socket. This executable was built without -f+" <> myGhcDebugFeatureFlag <> "." +{-# INLINE myGhcDebugSocketUnsupportedErrorMessage #-} +#endif + +myGhcDebugSocketDefaultLong :: String +myGhcDebugSocketDefaultLong = + "enable-my-ghc-debug-socket" +{-# INLINE myGhcDebugSocketDefaultLong #-} + +myGhcDebugSocketDefaultHelp :: String +myGhcDebugSocketDefaultHelp = + "Enable ghc-debug for this program." +{-# INLINE myGhcDebugSocketDefaultHelp #-} + +myGhcDebugSocketUnixLong :: String +myGhcDebugSocketUnixLong = + "enable-my-ghc-debug-socket-unix" +{-# INLINE myGhcDebugSocketUnixLong #-} + +myGhcDebugSocketUnixMetavar :: String +myGhcDebugSocketUnixMetavar = + "SOCKET" +{-# INLINE myGhcDebugSocketUnixMetavar #-} + +myGhcDebugSocketUnixHelp :: String +myGhcDebugSocketUnixHelp = + "Enable ghc-debug for this program on the given Unix socket." +{-# INLINE myGhcDebugSocketUnixHelp #-} + +myGhcDebugSocketTcpLong :: String +myGhcDebugSocketTcpLong = + "enable-my-ghc-debug-socket-tcp" +{-# INLINE myGhcDebugSocketTcpLong #-} + +myGhcDebugSocketTcpMetavar :: String +myGhcDebugSocketTcpMetavar = + "ADDRESS" +{-# INLINE myGhcDebugSocketTcpMetavar #-} + +myGhcDebugSocketTcpHelp :: String +myGhcDebugSocketTcpHelp = + "Enable ghc-debug for this program on the given TCP socket specified as 'host:port'." +{-# INLINE myGhcDebugSocketTcpHelp #-} diff --git a/src/GHC/Eventlog/Live/Otelcol.hs b/src/GHC/Eventlog/Live/Otelcol.hs --- a/src/GHC/Eventlog/Live/Otelcol.hs +++ b/src/GHC/Eventlog/Live/Otelcol.hs @@ -11,7 +11,7 @@ main, ) where -import Control.Applicative (Alternative (..), asum) +import Control.Applicative (asum) import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString) import Data.Coerce (Coercible, coerce) @@ -35,12 +35,12 @@ import Data.Version (showVersion) import Data.Word (Word32, Word64) import Data.Yaml qualified as Y -import GHC.Debug.Stub qualified as GHC.Debug (withGhcDebug, withGhcDebugTCP, withGhcDebugUnix) +import GHC.Debug.Stub.Compat (MyGhcDebugSocket (..), maybeMyGhcDebugSocketParser, withMyGhcDebug) import GHC.Eventlog.Live.Data.Attribute import GHC.Eventlog.Live.Data.Group (Group, GroupBy, GroupedBy) import GHC.Eventlog.Live.Data.Group qualified as DG import GHC.Eventlog.Live.Data.Metric (Metric (..)) -import GHC.Eventlog.Live.Logger (logDebug, logError) +import GHC.Eventlog.Live.Logger (logDebug) import GHC.Eventlog.Live.Machine.Analysis.Capability (CapabilityUsageSpan) import GHC.Eventlog.Live.Machine.Analysis.Capability qualified as M import GHC.Eventlog.Live.Machine.Analysis.Heap (MemReturnData (..)) @@ -78,10 +78,8 @@ import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields qualified as OT -import System.Exit (exitFailure) import System.Random (StdGen, initStdGen) import System.Random.Compat (uniformByteString) -import Text.Read (readEither) {- | The main function for @eventlog-live-otelcol@. @@ -833,7 +831,7 @@ OC.parserOptionGroup "Debug Options" $ MyDebugOptions <$> O.optional myEventlogSocketParser - <*> O.optional myGhcDebugSocketParser + <*> maybeMyGhcDebugSocketParser -------------------------------------------------------------------------------- -- My Eventlog Socket @@ -857,64 +855,6 @@ withMyEventlogSocket maybeMyEventlogSocket = for_ maybeMyEventlogSocket $ \(MyEventlogSocketUnix myEventlogSocket) -> Eventlog.Socket.startWait myEventlogSocket - --------------------------------------------------------------------------------- --- My GHC Debug - -data MyGhcDebugSocket - = MyGhcDebugSocketDefault - | MyGhcDebugSocketUnix FilePath - | MyGhcDebugSocketTcp String - deriving (Show) - -myGhcDebugSocketParser :: O.Parser MyGhcDebugSocket -myGhcDebugSocketParser = - myGhcDebugSocketDefaultParser - <|> myGhcDebugSocketUnixParser - <|> myGhcDebugSocketTcpParser - where - myGhcDebugSocketDefaultParser = - O.flag' - MyGhcDebugSocketDefault - ( O.long "enable-my-ghc-debug-socket" - <> O.help "Enable ghc-debug for this program." - ) - myGhcDebugSocketUnixParser = - MyGhcDebugSocketUnix - <$> O.strOption - ( O.long "enable-my-ghc-debug-socket-unix" - <> O.metavar "SOCKET" - <> O.help "Enable ghc-debug for this program on the given Unix socket." - ) - myGhcDebugSocketTcpParser = - MyGhcDebugSocketUnix - <$> O.strOption - ( O.long "enable-my-ghc-debug-socket-tcp" - <> O.metavar "ADDRESS" - <> O.help "Enable ghc-debug for this program on the given TCP socket specified as 'host:port'." - ) - -{- | -Internal helper. -Start @ghc-debug@ on the given `MyGhcDebugSocket`. --} -withMyGhcDebug :: Verbosity -> Maybe MyGhcDebugSocket -> IO a -> IO a -withMyGhcDebug verbosity maybeMyGhcDebugSocket action = - case maybeMyGhcDebugSocket of - Nothing -> action - Just MyGhcDebugSocketDefault -> - GHC.Debug.withGhcDebug action - Just (MyGhcDebugSocketUnix myGhcDebugSocketUnix) -> - GHC.Debug.withGhcDebugUnix myGhcDebugSocketUnix action - Just (MyGhcDebugSocketTcp myGhcDebugSocketTcp) -> do - let (host, port) = break (== ':') myGhcDebugSocketTcp - case readEither port of - Left _parseError -> do - logError verbosity $ - "Could not parse ghc-debug TCP address " <> T.pack myGhcDebugSocketTcp <> "." - exitFailure - Right portWord16 -> - GHC.Debug.withGhcDebugTCP host portWord16 action -------------------------------------------------------------------------------- -- Configuration