diff options
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Platform/Ways.hs | 104 | ||||
| -rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Unit/State.hs | 4 | ||||
| -rw-r--r-- | ghc/Main.hs | 4 | ||||
| -rw-r--r-- | includes/Rts.h | 9 | ||||
| -rw-r--r-- | rts/RtsSymbols.c | 3 | ||||
| -rw-r--r-- | rts/RtsUtils.c | 33 |
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) { |