Commit accdb24a authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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.
parent fd984d68
......@@ -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))
......
{-# 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
......@@ -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 ++ "_"
......
......@@ -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
......
......@@ -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
......
......@@ -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
-------------------------------------------------------------------------- */
......
......@@ -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) \
......
......@@ -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)
{
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment