[Git][ghc/ghc][master] base: speed up traceEventIO and friends when eventlogging is turned off #17949
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Oct 19 13:34:52 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a04959b8 by Daneel Yaitskov at 2024-10-19T09:34:15-04:00
base: speed up traceEventIO and friends when eventlogging is turned off #17949
Check the RTS flag before doing any work with the given lazy string.
Fix #17949
Co-authored-by: Michael Peyton Jones <me at michaelpj.com>
Co-authored-by: Sylvain Henry <sylvain at haskus.fr>
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
- - - - -
8 changed files:
- libraries/base/changelog.md
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- + libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc
- + testsuite/tests/perf/should_run/T17949.hs
- testsuite/tests/perf/should_run/all.T
- testsuite/tests/profiling/should_run/callstack002.stderr
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -37,6 +37,7 @@
for libraries that define exception-handling combinators like `catch` and
`onException`, such as `base`, or the `exceptions` package.
* Move `Lift ByteArray` and `Lift Fixed` instances into `base` from `template-haskell`. See [CLC proposal #287](https://github.com/haskell/core-libraries-committee/issues/287).
+ * Make `Debug.Trace.{traceEventIO,traceMarkerIO}` faster when tracing is disabled. See [CLC proposal #291](https://github.com/haskell/core-libraries-committee/issues/291).
## 4.20.0.0 May 2024
* Shipped with GHC 9.10.1
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -253,6 +253,7 @@ Library
GHC.Internal.Records
GHC.Internal.ResponseFile
GHC.Internal.RTS.Flags
+ GHC.Internal.RTS.Flags.Test
GHC.Internal.ST
GHC.Internal.Stack.CloneStack
GHC.Internal.StaticPtr
=====================================
libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -54,6 +55,11 @@ import GHC.Internal.Ptr
import GHC.Internal.Show
import GHC.Internal.Stack
import GHC.Internal.Data.List (null, partition)
+import GHC.Internal.RTS.Flags.Test
+
+-- | 'userEventTracingEnabled' is True if event logging for user events (@+RTS -l@) is enabled.
+userEventTracingEnabled :: IO Bool
+userEventTracingEnabled = getUserEventTracingEnabled
-- | The 'traceIO' function outputs the trace message from the IO monad.
-- This sequences the output with respect to other IO actions.
@@ -239,8 +245,8 @@ traceStack str expr = unsafePerformIO $ do
{-# NOINLINE traceEvent #-}
-- | The 'traceEvent' function behaves like 'trace' with the difference that
--- the message is emitted to the eventlog, if eventlog profiling is available
--- and enabled at runtime.
+-- the message is emitted to the eventlog, if eventlog tracing is available
+-- and user event tracing is enabled at runtime.
--
-- It is suitable for use in pure code. In an IO context use 'traceEventIO'
-- instead.
@@ -256,16 +262,19 @@ traceEvent msg expr = unsafeDupablePerformIO $ do
return expr
-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog
--- profiling is available and enabled at runtime.
+-- tracing is available and user event tracing is enabled at runtime.
--
-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to
-- other IO actions.
--
-- @since base-4.5.0.0
traceEventIO :: String -> IO ()
-traceEventIO msg =
- Enc.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
- case traceEvent# p s of s' -> (# s', () #)
+{-# INLINE traceEventIO #-}
+traceEventIO msg = do
+ enabled <- userEventTracingEnabled
+ when enabled $
+ Enc.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
+ case traceEvent# p s of s' -> (# s', () #)
-- | Like 'traceEvent', but emits the result of calling a function on its
-- argument.
@@ -276,7 +285,7 @@ traceEventWith f a = traceEvent (f a) a
{-# NOINLINE traceMarker #-}
-- | The 'traceMarker' function emits a marker to the eventlog, if eventlog
--- profiling is available and enabled at runtime. The @String@ is the name of
+-- tracing is available and enabled at runtime. The @String@ is the name of
-- the marker. The name is just used in the profiling tools to help you keep
-- clear which marker is which.
--
@@ -294,16 +303,19 @@ traceMarker msg expr = unsafeDupablePerformIO $ do
return expr
-- | The 'traceMarkerIO' function emits a marker to the eventlog, if eventlog
--- profiling is available and enabled at runtime.
+-- tracing is available and user event tracing is enabled at runtime.
--
-- Compared to 'traceMarker', 'traceMarkerIO' sequences the event with respect to
-- other IO actions.
--
-- @since base-4.7.0.0
traceMarkerIO :: String -> IO ()
-traceMarkerIO msg =
- Enc.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
- case traceMarker# p s of s' -> (# s', () #)
+{-# INLINE traceMarkerIO #-}
+traceMarkerIO msg = do
+ enabled <- userEventTracingEnabled
+ when enabled $
+ Enc.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
+ case traceMarker# p s of s' -> (# s', () #)
-- | Immediately flush the event log, if enabled.
--
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
=====================================
@@ -613,6 +613,10 @@ getProfFlags = do
getTraceFlags :: IO TraceFlags
getTraceFlags = do
+#if defined(javascript_HOST_ARCH)
+ -- The JS backend does not currently have trace flags
+ pure (TraceFlags TraceNone False False False False False False False)
+#else
let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr
TraceFlags <$> (toEnum . fromIntegral
<$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt))
@@ -630,6 +634,7 @@ getTraceFlags = do
(#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool))
<*> (toBool <$>
(#{peek TRACE_FLAGS, user} ptr :: IO CBool))
+#endif
getTickyFlags :: IO TickyFlags
getTickyFlags = do
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Module with fewer dependencies than GHC.Internal.RTS.Flags
+-- that allows to quickly test if some flag is set.
+module GHC.Internal.RTS.Flags.Test
+ ( getUserEventTracingEnabled
+ )
+where
+
+import GHC.Internal.Base
+
+#if !defined(javascript_HOST_ARCH)
+
+import GHC.Internal.Ptr
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.Foreign.Marshal.Utils
+import GHC.Internal.Foreign.Storable
+import GHC.Internal.Data.Functor ((<$>))
+
+#include "Rts.h"
+#include "rts/Flags.h"
+
+foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr ()
+#endif
+
+-- | Specialized version of 'getTraceFlags' for just checking if user
+-- event tracing is enabled.
+getUserEventTracingEnabled :: IO Bool
+getUserEventTracingEnabled = do
+#if defined(javascript_HOST_ARCH)
+ -- The JS backend does not currently have trace flags
+ pure False
+#else
+ let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr
+ toBool <$> (#{peek TRACE_FLAGS, user} ptr :: IO CBool)
+#endif
=====================================
testsuite/tests/perf/should_run/T17949.hs
=====================================
@@ -0,0 +1,7 @@
+module Main where
+
+import Debug.Trace
+
+main :: IO ()
+main = do
+ traceEventIO (show [0..1234567])
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -414,3 +414,4 @@ test('T21839r',
test('T18964', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O'])
test('T23021', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2'])
test('T25055', [collect_stats('bytes allocated', 2), only_ways(['normal'])], compile_and_run, ['-O2'])
+test('T17949', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2'])
=====================================
testsuite/tests/profiling/should_run/callstack002.stderr
=====================================
@@ -1,6 +1,6 @@
f: 42
CallStack (from -prof):
- GHC.Internal.Debug.Trace.traceStack (libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs:234:1-10)
+ GHC.Internal.Debug.Trace.traceStack (libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs:240:1-10)
Main.f (callstack002.hs:10:7-43)
Main.map.go (callstack002.hs:15:21-23)
Main.map.go (callstack002.hs:15:21-34)
@@ -9,7 +9,7 @@ CallStack (from -prof):
Main.CAF (<entire-module>)
f: 43
CallStack (from -prof):
- GHC.Internal.Debug.Trace.traceStack (libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs:234:1-10)
+ GHC.Internal.Debug.Trace.traceStack (libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs:240:1-10)
Main.f (callstack002.hs:10:7-43)
Main.map.go (callstack002.hs:15:21-23)
Main.map.go (callstack002.hs:15:21-34)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a04959b8964c8d09897cfae1fd7b06ac53ebee95
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a04959b8964c8d09897cfae1fd7b06ac53ebee95
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241019/617385b5/attachment-0001.html>
More information about the ghc-commits
mailing list