diff options
| author | Daneel Yaitskov <dyaitskov@gmail.com> | 2020-05-21 17:53:11 -0700 |
|---|---|---|
| committer | Adam Sandberg Ericsson <adam@sandbergericsson.se> | 2021-08-03 14:23:51 +0200 |
| commit | 0d518586be16490d5cbb875313e28eb1d3b9e60a (patch) | |
| tree | e7b079ed4aaa2d4dc2a48296cce3078f05eb9cde | |
| parent | 34e352173dd1fc3cd86c49380fda5a4eb5dd7aef (diff) | |
| download | haskell-wip/T17949.tar.gz | |
base: speed up traceEventIO and friends when eventlogging is turned off #17949wip/T17949
| -rw-r--r-- | libraries/base/Debug/Trace.hs | 20 | ||||
| -rw-r--r-- | libraries/base/GHC/RTS/Flags.hsc | 1 |
2 files changed, 17 insertions, 4 deletions
diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs index e85fb7590a..fa467e5f09 100644 --- a/libraries/base/Debug/Trace.hs +++ b/libraries/base/Debug/Trace.hs @@ -47,11 +47,13 @@ module Debug.Trace ( import System.IO.Unsafe +import Control.Monad ((<$!>)) import Foreign.C.String import GHC.Base import qualified GHC.Foreign import GHC.IO.Encoding import GHC.Ptr +import GHC.RTS.Flags import GHC.Show import GHC.Stack import Data.List (null, partition) @@ -74,6 +76,13 @@ import Data.List (null, partition) -- Some implementations of these functions may decorate the string that\'s -- output to indicate that you\'re tracing. +-- | 'userTracingEnabled' is True if eventlogging (@+RTS -l@) is enabled. +-- +-- It doesn't update if you modify the trace-flags after the first time you +-- call it. +userTracingEnabled :: Bool +userTracingEnabled = unsafeDupablePerformIO $ user <$!> inline getTraceFlags + -- | The 'traceIO' function outputs the trace message from the IO monad. -- This sequences the output with respect to other IO actions. -- @@ -269,8 +278,10 @@ traceEvent msg expr = unsafeDupablePerformIO $ do -- @since 4.5.0.0 traceEventIO :: String -> IO () traceEventIO msg = - GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> - case traceEvent# p s of s' -> (# s', () #) + when userTracingEnabled + (GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> + case traceEvent# p s of s' -> (# s', () #)) + -- $markers -- @@ -319,8 +330,9 @@ traceMarker msg expr = unsafeDupablePerformIO $ do -- @since 4.7.0.0 traceMarkerIO :: String -> IO () traceMarkerIO msg = - GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> - case traceMarker# p s of s' -> (# s', () #) + when userTracingEnabled + (GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s -> + case traceMarker# p s of s' -> (# s', () #)) -- | Immediately flush the event log, if enabled. -- diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index 138033758b..dff0ba1122 100644 --- a/libraries/base/GHC/RTS/Flags.hsc +++ b/libraries/base/GHC/RTS/Flags.hsc @@ -603,6 +603,7 @@ getProfFlags = do <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, retainerSelector} ptr) <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, bioSelector} ptr) +{-# INLINABLE getTraceFlags #-} getTraceFlags :: IO TraceFlags getTraceFlags = do let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr |