[Git][ghc/ghc][wip/T17949] T17949 try @maoe way

[Daneel S. Yaitskov]

Daneel S. Yaitskov pushed to branch wip/T17949 at Glasgow Haskell Compiler / GHC


Commits:
480b208d by Daneel Yaitskov at 2020-05-28T21:16:26-07:00
T17949 try @maoe way

- - - - -


4 changed files:

- includes/Rts.h
- libraries/base/Debug/Trace.hs
- rts/Trace.c
- rts/Trace.h


Changes:

=====================================
includes/Rts.h
=====================================
@@ -57,10 +57,8 @@ extern "C" {
 // library.
 #if defined(HAS_VISIBILITY_HIDDEN)
 #define RTS_PRIVATE  GNUC3_ATTRIBUTE(visibility("hidden"))
-#define RTS_DEFAULT  GNUC3_ATTRIBUTE(visibility("default"))
 #else
 #define RTS_PRIVATE  /* disabled: RTS_PRIVATE */
-#define RTS_DEFAULT
 #endif
 
 #if __GNUC__ >= 4


=====================================
libraries/base/Debug/Trace.hs
=====================================
@@ -46,14 +46,13 @@ module Debug.Trace (
 
 import System.IO.Unsafe
 
-import Foreign
+import Control.Monad ((<$!>))
 import Foreign.C.String
-import Foreign.C.Types
 import GHC.Base
 import qualified GHC.Foreign
 import GHC.IO.Encoding
 import GHC.Ptr
-import GHC.Real
+import GHC.RTS.Flags
 import GHC.Show
 import GHC.Stack
 import Data.List (null, partition)
@@ -76,7 +75,8 @@ import Data.List (null, partition)
 -- Some implementations of these functions may decorate the string that\'s
 -- output to indicate that you\'re tracing.
 
-foreign import ccall "&TRACE_user" traceUser :: Ptr CInt
+userTracingEnabled :: Bool
+userTracingEnabled = unsafeDupablePerformIO $ user <$!> inline getTraceFlags
 
 -- | The 'whenEventlog' function runs the argument action
 -- if eventlogging (+RTS -l) is enabled.
@@ -85,8 +85,7 @@ foreign import ccall "&TRACE_user" traceUser :: Ptr CInt
 {-# INLINE whenEventlog #-}
 whenEventlog :: IO () -> IO ()
 whenEventlog logAction = do
-  ee <- peek traceUser
-  if 0 < (fromIntegral ee :: Int)
+  if userTracingEnabled
   then logAction
   else return ()
 


=====================================
rts/Trace.c
=====================================
@@ -33,9 +33,7 @@ int TRACE_gc;
 int TRACE_nonmoving_gc;
 int TRACE_spark_sampled;
 int TRACE_spark_full;
-#endif /* TRACING */
-RTS_DEFAULT int TRACE_user; // used in Debug.Trace
-#if defined(TRACING)
+int TRACE_user;
 int TRACE_cap;
 
 #if defined(THREADED_RTS)


=====================================
rts/Trace.h
=====================================
@@ -71,7 +71,7 @@ extern int TRACE_sched;
 extern int TRACE_gc;
 extern int TRACE_spark_sampled;
 extern int TRACE_spark_full;
-
+/* extern int TRACE_user; */  // only used in Trace.c
 extern int TRACE_cap;
 extern int TRACE_nonmoving_gc;
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/480b208d78de5e236bd7e4fc682c83f05077b270

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/480b208d78de5e236bd7e4fc682c83f05077b270
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/20200529/bfbe6b72/attachment-0001.html>