Expose RTS-only ways (#18651)

Some RTS ways are exposed via settings (ghcThreaded, ghcDebugged) but
not all. It's simpler if the RTS exposes them all itself.

8 files changed, 134 insertions, 27 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index dcbe1b660c..a603ba5063 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2182,7 +2182,7 @@ dynamic_flags_deps = [
 
     ------- ways ---------------------------------------------------------------
   , make_ord_flag defGhcFlag "prof"           (NoArg (addWay WayProf))
-  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWay WayEventLog))
+  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWay WayTracing))
   , make_ord_flag defGhcFlag "debug"          (NoArg (addWay WayDebug))
   , make_ord_flag defGhcFlag "threaded"       (NoArg (addWay WayThreaded))
 
diff --git a/compiler/GHC/Platform/Ways.hs b/compiler/GHC/Platform/Ways.hs
index c4ba0e18de..9d01ffe878 100644
--- a/compiler/GHC/Platform/Ways.hs
+++ b/compiler/GHC/Platform/Ways.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -- | Ways
 --
 -- The central concept of a "way" is that all objects in a given
@@ -33,13 +35,21 @@ module GHC.Platform.Ways
    , wayTag
    , waysTag
    , waysBuildTag
+   , fullWays
+   , rtsWays
    -- * Host GHC ways
+   , hostWays
    , hostFullWays
    , hostIsProfiled
    , hostIsDynamic
+   , hostIsThreaded
+   , hostIsDebugged
+   , hostIsTracing
    )
 where
 
+#include "HsVersions.h"
+
 import GHC.Prelude
 import GHC.Platform
 import GHC.Driver.Flags
@@ -47,7 +57,6 @@ import GHC.Driver.Flags
 import qualified Data.Set as Set
 import Data.Set (Set)
 import Data.List (intersperse)
-import System.IO.Unsafe ( unsafeDupablePerformIO )
 
 -- | A way
 --
@@ -58,7 +67,7 @@ data Way
   | WayThreaded      -- ^ (RTS only) Multithreaded runtime system
   | WayDebug         -- ^ Debugging, enable trace messages and extra checks
   | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports
-  | WayEventLog      -- ^ (RTS only) enable event logging
+  | WayTracing       -- ^ (RTS only) enable event logging (tracing)
   | WayDyn           -- ^ Dynamic linking
   deriving (Eq, Ord, Show)
 
@@ -96,7 +105,7 @@ wayTag WayThreaded    = "thr"
 wayTag WayDebug       = "debug"
 wayTag WayDyn         = "dyn"
 wayTag WayProf        = "p"
-wayTag WayEventLog    = "l"
+wayTag WayTracing     = "l" -- "l" for "logging"
 
 -- | Return true for ways that only impact the RTS, not the generated code
 wayRTSOnly :: Way -> Bool
@@ -105,7 +114,15 @@ wayRTSOnly WayDyn         = False
 wayRTSOnly WayProf        = False
 wayRTSOnly WayThreaded    = True
 wayRTSOnly WayDebug       = True
-wayRTSOnly WayEventLog    = True
+wayRTSOnly WayTracing     = True
+
+-- | Filter ways that have an impact on compilation
+fullWays :: Ways -> Ways
+fullWays ws = Set.filter (not . wayRTSOnly) ws
+
+-- | Filter RTS-only ways (ways that don't have an impact on compilation)
+rtsWays :: Ways -> Ways
+rtsWays ws = Set.filter wayRTSOnly ws
 
 wayDesc :: Way -> String
 wayDesc (WayCustom xs) = xs
@@ -113,7 +130,7 @@ wayDesc WayThreaded    = "Threaded"
 wayDesc WayDebug       = "Debug"
 wayDesc WayDyn         = "Dynamic"
 wayDesc WayProf        = "Profiling"
-wayDesc WayEventLog    = "RTS Event Logging"
+wayDesc WayTracing     = "Tracing"
 
 -- | Turn these flags on when enabling this way
 wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
@@ -129,7 +146,7 @@ wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]
     -- PIC objects can be linked into a .so, we have to compile even
     -- modules of the main program with -fPIC when using -dynamic.
 wayGeneralFlags _ WayProf     = []
-wayGeneralFlags _ WayEventLog = []
+wayGeneralFlags _ WayTracing  = []
 
 -- | Turn these flags off when enabling this way
 wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]
@@ -140,7 +157,7 @@ wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]
    -- There's no point splitting when we're going to be dynamically linking.
    -- Plus it breaks compilation on OSX x86.
 wayUnsetGeneralFlags _ WayProf     = []
-wayUnsetGeneralFlags _ WayEventLog = []
+wayUnsetGeneralFlags _ WayTracing  = []
 
 -- | Pass these options to the C compiler when enabling this way
 wayOptc :: Platform -> Way -> [String]
@@ -152,7 +169,7 @@ wayOptc platform WayThreaded = case platformOS platform of
 wayOptc _ WayDebug      = []
 wayOptc _ WayDyn        = []
 wayOptc _ WayProf       = ["-DPROFILING"]
-wayOptc _ WayEventLog   = ["-DTRACING"]
+wayOptc _ WayTracing    = ["-DTRACING"]
 
 -- | Pass these options to linker when enabling this way
 wayOptl :: Platform -> Way -> [String]
@@ -168,7 +185,7 @@ wayOptl platform WayThreaded =
 wayOptl _ WayDebug      = []
 wayOptl _ WayDyn        = []
 wayOptl _ WayProf       = []
-wayOptl _ WayEventLog   = []
+wayOptl _ WayTracing    = []
 
 -- | Pass these options to the preprocessor when enabling this way
 wayOptP :: Platform -> Way -> [String]
@@ -177,29 +194,74 @@ wayOptP _ WayThreaded = []
 wayOptP _ WayDebug    = []
 wayOptP _ WayDyn      = []
 wayOptP _ WayProf     = ["-DPROFILING"]
-wayOptP _ WayEventLog = ["-DTRACING"]
+wayOptP _ WayTracing  = ["-DTRACING"]
 
 
 -- | Consult the RTS to find whether it has been built with profiling enabled.
 hostIsProfiled :: Bool
-hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
+hostIsProfiled = rtsIsProfiled_ /= 0
 
-foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int
+foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int
 
 -- | Consult the RTS to find whether GHC itself has been built with
 -- dynamic linking.  This can't be statically known at compile-time,
 -- because we build both the static and dynamic versions together with
 -- -dynamic-too.
 hostIsDynamic :: Bool
-hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0
+hostIsDynamic = rtsIsDynamic_ /= 0
 
-foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int
+foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int
 
--- | Return host "full" ways (i.e. ways that have an impact on the compilation,
--- not RTS only ways). These ways must be used when compiling codes targeting
--- the internal interpreter.
-hostFullWays :: Ways
-hostFullWays = Set.unions
-   [ if hostIsDynamic  then Set.singleton WayDyn  else Set.empty
-   , if hostIsProfiled then Set.singleton WayProf else Set.empty
+-- we need this until the bootstrap GHC is always recent enough
+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
+
+-- | Consult the RTS to find whether it is threaded.
+hostIsThreaded :: Bool
+hostIsThreaded = rtsIsThreaded_ /= 0
+
+foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int
+
+-- | Consult the RTS to find whether it is debugged.
+hostIsDebugged :: Bool
+hostIsDebugged = rtsIsDebugged_ /= 0
+
+foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int
+
+-- | Consult the RTS to find whether it is tracing.
+hostIsTracing :: Bool
+hostIsTracing = rtsIsTracing_ /= 0
+
+foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int
+
+
+#else
+
+hostIsThreaded :: Bool
+hostIsThreaded = False
+
+hostIsDebugged :: Bool
+hostIsDebugged = False
+
+hostIsTracing :: Bool
+hostIsTracing = False
+
+#endif
+
+
+-- | Host ways.
+hostWays :: Ways
+hostWays = Set.unions
+   [ if hostIsDynamic  then Set.singleton WayDyn      else Set.empty
+   , if hostIsProfiled then Set.singleton WayProf     else Set.empty
+   , if hostIsThreaded then Set.singleton WayThreaded else Set.empty
+   , if hostIsDebugged then Set.singleton WayDebug    else Set.empty
+   , if hostIsTracing  then Set.singleton WayTracing  else Set.empty
    ]
+
+-- | Host "full" ways (i.e. ways that have an impact on the compilation,
+-- not RTS only ways).
+--
+-- These ways must be used when compiling codes targeting the internal
+-- interpreter.
+hostFullWays :: Ways
+hostFullWays = fullWays hostWays
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs
index 9ab708e13d..5d0eb3c467 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Runtime/Linker.hs
@@ -596,7 +596,7 @@ checkNonStdWay hsc_env srcspan
 
   | otherwise = return (Just (hostWayTag ++ "o"))
   where
-    targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))
+    targetFullWays = fullWays (ways (hsc_dflags hsc_env))
     hostWayTag = case waysTag hostFullWays of
                   "" -> ""
                   tag -> tag ++ "_"
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index c95c9e4031..be5b08110d 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -1856,11 +1856,11 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (unitLibraries p)
 
         -- debug and profiled RTSs include support for -eventlog
         ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1
-              = Set.filter (/= WayEventLog) ways1
+              = Set.filter (/= WayTracing) ways1
               | otherwise
               = ways1
 
-        tag     = waysTag (Set.filter (not . wayRTSOnly) ways2)
+        tag     = waysTag (fullWays ways2)
         rts_tag = waysTag ways2
 
         mkDynName x
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 06a26c45ae..122e4dce0c 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -348,12 +348,12 @@ checkOptions mode dflags srcs objs = do
    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 
-   when (not (Set.null (Set.filter wayRTSOnly (ways dflags)))
+   when (not (Set.null (rtsWays (ways dflags)))
          && isInterpretiveMode mode) $
         hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
 
         -- -prof and --interactive are not a good combination
-   when ((Set.filter (not . wayRTSOnly) (ways dflags) /= hostFullWays)
+   when ((fullWays (ways dflags) /= hostFullWays)
          && isInterpretiveMode mode
          && not (gopt Opt_ExternalInterpreter dflags)) $
       do throwGhcException (UsageError
diff --git a/includes/Rts.h b/includes/Rts.h
index 589ef8b82c..5768e0eb7d 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -263,6 +263,15 @@ int rts_isProfiled(void);
 // Returns non-zero if the RTS is a dynamically-linked version
 int rts_isDynamic(void);
 
+// Returns non-zero if the RTS is a threaded version
+int rts_isThreaded(void);
+
+// Returns non-zero if the RTS is a debugged version
+int rts_isDebugged(void);
+
+// Returns non-zero if the RTS is a tracing version (event log)
+int rts_isTracing(void);
+
 /* -----------------------------------------------------------------------------
    RTS Exit codes
    -------------------------------------------------------------------------- */
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 3a2e37fd63..6d3ff2929e 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -803,6 +803,9 @@
       SymI_HasProto(rtsSupportsBoundThreads)                            \
       SymI_HasProto(rts_isProfiled)                                     \
       SymI_HasProto(rts_isDynamic)                                      \
+      SymI_HasProto(rts_isThreaded)                                     \
+      SymI_HasProto(rts_isDebugged)                                     \
+      SymI_HasProto(rts_isTracing)                                      \
       SymI_HasProto(rts_setInCallCapability)                            \
       SymI_HasProto(rts_enableThreadAllocationLimit)                    \
       SymI_HasProto(rts_disableThreadAllocationLimit)                   \
diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c
index e88babcd08..ca01bdb6e0 100644
--- a/rts/RtsUtils.c
+++ b/rts/RtsUtils.c
@@ -363,6 +363,39 @@ int rts_isDynamic(void)
 #endif
 }
 
+// Provides a way for Haskell programs to tell whether they're
+// linked with the threaded runtime or not.
+int rts_isThreaded(void)
+{
+#if defined(THREADED_RTS)
+    return 1;
+#else
+    return 0;
+#endif
+}
+
+// Provides a way for Haskell programs to tell whether they're
+// linked with the debug runtime or not.
+int rts_isDebugged(void)
+{
+#if defined(DEBUG)
+    return 1;
+#else
+    return 0;
+#endif
+}
+
+// Provides a way for Haskell programs to tell whether they're
+// linked with the tracing runtime or not.
+int rts_isTracing(void)
+{
+#if defined(TRACING)
+    return 1;
+#else
+    return 0;
+#endif
+}
+
 // Used for detecting a non-empty FPU stack on x86 (see #4914)
 void checkFPUStack(void)
 {