From 0d518586be16490d5cbb875313e28eb1d3b9e60a Mon Sep 17 00:00:00 2001
From: Daneel Yaitskov <dyaitskov@gmail.com>
Date: Thu, 21 May 2020 17:53:11 -0700
Subject: base: speed up traceEventIO and friends when eventlogging is turned
 off #17949

---
 libraries/base/Debug/Trace.hs    | 20 ++++++++++++++++----
 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
-- 
cgit v1.2.1