[Git][ghc/ghc][master] Expose RTS-only ways (#18651)
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 9 12:42:55 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
accdb24a by Sylvain Henry at 2020-10-09T08:42:31-04:00
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 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Platform/Ways.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Unit/State.hs
- ghc/Main.hs
- includes/Rts.h
- rts/RtsSymbols.c
- rts/RtsUtils.c
Changes:
=====================================
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))
=====================================
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
=====================================
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 ++ "_"
=====================================
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
=====================================
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
=====================================
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
-------------------------------------------------------------------------- */
=====================================
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) \
=====================================
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)
{
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/accdb24a086b80fe74776246aa33bce5a920e3c8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/accdb24a086b80fe74776246aa33bce5a920e3c8
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/20201009/1ca6eee3/attachment-0001.html>
More information about the ghc-commits
mailing list