[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 13 commits: gitlab-ci: Mark T22012 as broken on CentOS 7
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Sep 26 23:28:11 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
de142aa2 by Ben Gamari at 2023-09-26T15:25:03-04:00
gitlab-ci: Mark T22012 as broken on CentOS 7
Due to #23979.
- - - - -
6a896ce8 by Teo Camarasu at 2023-09-26T15:25:39-04:00
hadrian: better error for failing to find file's dependencies
Resolves #24004
- - - - -
d697a6c2 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Refactor uses of `partitionEithers . map`
This patch changes occurences of the idiom
`partitionEithers (map f xs)` by the simpler form
`partitionWith f xs` where `partitionWith` is the utility function
defined in `GHC.Utils.Misc`.
Resolves: #23953
- - - - -
8a2968b7 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Refactor uses of `partitionEithers <$> mapM f xs`
This patch changes occurences of the idiom
`partitionEithers <$> mapM f xs` by the simpler form
`partitionWithM f xs` where `partitionWithM` is a utility function
newly added to `GHC.Utils.Misc`.
- - - - -
6a27eb97 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Mark `GHC.Utils.Misc.partitionWithM` as inlineable
This patch adds an `INLINEABLE` pragma for `partitionWithM` to ensure
that the right-hand side of the definition of this function remains
available for specialisation at call sites.
- - - - -
e24c962e by David Binder at 2023-09-26T19:27:50-04:00
Add RTS option to supress tix file
- - - - -
efce93e8 by David Binder at 2023-09-26T19:27:51-04:00
Add expected output to testsuite in test interface-stability/base-exports
- - - - -
23411044 by David Binder at 2023-09-26T19:27:51-04:00
Expose HpcFlags and getHpcFlags from GHC.RTS.Flags
- - - - -
222318c7 by David Binder at 2023-09-26T19:27:51-04:00
Fix expected output of interface-stability test
- - - - -
f1449647 by David Binder at 2023-09-26T19:27:51-04:00
Implement getHpcFlags
- - - - -
ce7b51bf by David Binder at 2023-09-26T19:27:51-04:00
Add section in user guide
- - - - -
fa3796e7 by David Binder at 2023-09-26T19:27:51-04:00
Rename --emit-tix-file to --write-tix-file
- - - - -
c7154342 by David Binder at 2023-09-26T19:27:51-04:00
Update the golden files for interface stability
- - - - -
24 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToJS/Deps.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Sinker.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Utils/Misc.hs
- docs/users_guide/runtime_control.rst
- hadrian/src/Hadrian/Oracles/TextFile.hs
- libraries/base/GHC/RTS/Flags.hsc
- rts/Hpc.c
- rts/RtsFlags.c
- rts/include/rts/Flags.h
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -447,7 +447,8 @@ distroVariables :: LinuxDistro -> Variables
distroVariables Alpine312 = alpineVariables
distroVariables Alpine318 = alpineVariables
distroVariables Centos7 = mconcat [
- "HADRIAN_ARGS" =: "--docs=no-sphinx"
+ "HADRIAN_ARGS" =: "--docs=no-sphinx"
+ , "BROKEN_TESTS" =: "T22012" -- due to #23979
]
distroVariables Rocky8 = mconcat [
"HADRIAN_ARGS" =: "--docs=no-sphinx"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1141,6 +1141,7 @@
"variables": {
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-linux-centos7-validate",
+ "BROKEN_TESTS": "T22012",
"BUILD_FLAVOUR": "validate",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -3301,6 +3302,7 @@
"variables": {
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-linux-centos7-release+no_split_sections",
+ "BROKEN_TESTS": "T22012",
"BUILD_FLAVOUR": "release+no_split_sections",
"CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx",
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
-import GHC.Utils.Misc ( seqList )
+import GHC.Utils.Misc ( partitionWith, seqList )
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
@@ -58,7 +58,6 @@ import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
-import Data.Either ( partitionEithers )
-- | Debug information about a block of code. Ticks scope over nested
-- blocks.
@@ -110,7 +109,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
-- Analyse tick scope structure: Each one is either a top-level
-- tick scope, or the child of another.
(topScopes, childScopes)
- = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
+ = partitionWith (\a -> findP a a) $ Map.keys blockCtxs
findP tsc GlobalScope = Left tsc -- top scope
findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
| otherwise = findP tsc scp'
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -26,11 +26,11 @@ import GHC.Types.Unique.Supply
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
+import GHC.Utils.Misc ( partitionWithM )
import GHC.Platform
import Control.Monad
-import Data.Either (partitionEithers)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
@@ -50,9 +50,7 @@ cmmPipeline logger cmm_config srtInfo prog = do
let forceRes (info, group) = info `seq` foldr seq () group
let platform = cmmPlatform cmm_config
withTimingSilent logger (text "Cmm pipeline") forceRes $ do
- tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog
-
- let (procs, data_) = partitionEithers tops
+ (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config) prog
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_
dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1569,9 +1569,8 @@ downsweep :: HscEnv
-- which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do
- rootSummaries <- mapM getRootSummary roots
- let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
- root_map = mkRootMap rootSummariesOk
+ (root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549
+ let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
(deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -124,7 +124,6 @@ import System.IO
import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
-import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
@@ -489,8 +488,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
Right t -> do
-- first check object files and extra_ld_inputs
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
- e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
- let (errs,extra_times) = partitionEithers e_extra_times
+ (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs
let obj_times = map linkableTime linkables ++ extra_times
if not (null errs) || any (t <) obj_times
then return $ needsRecompileBecause ObjectsChanged
@@ -514,9 +512,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do
- e_lib_times <- mapM (tryIO . getModificationUTCTime)
- (catMaybes pkg_libfiles)
- let (lib_errs,lib_times) = partitionEithers e_lib_times
+ (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles)
if not (null lib_errs) || any (t <) lib_times
then return $ needsRecompileBecause LibraryChanged
else do
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -91,7 +91,6 @@ import Control.Monad (foldM, forM, guard, mzero, when, filterM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict
import Data.Coerce
-import Data.Either (partitionEithers)
import Data.Foldable (foldlM, minimumBy, toList)
import Data.Monoid (Any(..))
import Data.List (sortBy, find)
@@ -608,7 +607,7 @@ addPhiCts nabla cts = runMaybeT $ do
inhabitationTest initFuel (nabla_ty_st nabla) nabla''
partitionPhiCts :: PhiCts -> ([PredType], [PhiCt])
-partitionPhiCts = partitionEithers . map to_either . toList
+partitionPhiCts = partitionWith to_either . toList
where
to_either (PhiTyCt pred_ty) = Left pred_ty
to_either ct = Right ct
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -55,7 +55,6 @@ import Control.Applicative
import qualified Data.Set as Set
import qualified Data.Map as M
import Data.List (isSuffixOf)
-import Data.Either
import System.FilePath
import System.Directory
@@ -131,7 +130,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
let
-- 2. Exclude ones already linked
-- Main reason: avoid findModule calls in get_linkable
- (mods_needed, links_got) = partitionEithers (map split_mods mods_s)
+ (mods_needed, links_got) = partitionWith split_mods mods_s
pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
split_mods mod =
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -130,7 +130,6 @@ import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import Data.Dynamic
-import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
@@ -808,7 +807,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
findGlobalRdrEnv hsc_env imports
= do { idecls_env <- hscRnImportDecls hsc_env idecls
-- This call also loads any orphan modules
- ; return $ case partitionEithers (map mkEnv imods) of
+ ; return $ case partitionWith mkEnv imods of
(err : _, _) -> Left err
([], imods_env0) ->
-- Need to rehydrate the 'GlobalRdrEnv' to recover the 'GREInfo's.
=====================================
compiler/GHC/StgToJS/Deps.hs
=====================================
@@ -48,7 +48,6 @@ import qualified Data.IntSet as IS
import qualified GHC.Data.Word64Map as WM
import GHC.Data.Word64Map (Word64Map)
import Data.Array
-import Data.Either
import Data.Word
import Control.Monad
@@ -101,9 +100,9 @@ genDependencyData mod units = do
-> Int
-> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun])
oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do
- (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
- (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
- (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps
+ (edi, bdi) <- partitionWithM (lookupIdFun n) idDeps
+ (edo, bdo) <- partitionWithM lookupOtherFun otherDeps
+ (edp, bdp) <- partitionWithM (lookupPseudoIdFun n) pseudoIdDeps
expi <- mapM lookupExportedId (filter isExportedId idExports)
expo <- mapM lookupExportedOther otherExports
-- fixme thin deps, remove all transitive dependencies!
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -80,7 +80,6 @@ import qualified GHC.Data.List.SetOps as ListSetOps
import Data.Monoid
import Data.Maybe
import Data.Function
-import Data.Either
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Map as M
@@ -496,9 +495,10 @@ optimizeFree offset ids = do
l = length ids'
slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots
let slm = M.fromList (zip slots [0..])
- (remaining, fixed) = partitionEithers $
- map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True))
- (M.lookup (SlotId i n) slm)) ids'
+ (remaining, fixed) = partitionWith (\inp@(i,n) -> maybe (Left inp)
+ (\j -> Right (i,n,j,True))
+ (M.lookup (SlotId i n) slm))
+ ids'
takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed)
freeSlots = filter (`S.notMember` takenSlots) [0..l-1]
remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots
@@ -508,7 +508,7 @@ optimizeFree offset ids = do
-- | Allocate local closures
allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
allocCls dynMiddle xs = do
- (stat, dyn) <- partitionEithers <$> mapM toCl xs
+ (stat, dyn) <- partitionWithM toCl xs
ac <- allocDynAll False dynMiddle dyn
pure (mconcat stat <> ac)
where
=====================================
compiler/GHC/StgToJS/Sinker.hs
=====================================
@@ -15,10 +15,10 @@ import GHC.Unit.Module
import GHC.Types.Literal
import GHC.Data.Graph.Directed
+import GHC.Utils.Misc (partitionWith)
import GHC.StgToJS.Utils
import Data.Char
-import Data.Either
import Data.List (partition)
import Data.Maybe
@@ -38,7 +38,7 @@ sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits)
where
selectLifted (StgTopLifted b) = Left b
selectLifted x = Right x
- (pgm', stringLits) = partitionEithers (map selectLifted pgm)
+ (pgm', stringLits) = partitionWith selectLifted pgm
(sunk, pgm'') = sinkPgm' m pgm'
sinkPgm'
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Types.SourceFile ( hscSourceString )
import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
import GHC.Utils.Outputable
+import GHC.Utils.Misc ( partitionWith )
import System.FilePath
import qualified Data.Map as Map
@@ -68,7 +69,6 @@ import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
-import Data.Either
import Data.Function
import Data.List (sort)
import GHC.Data.List.SetOps
@@ -336,7 +336,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
- (boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries)
+ (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries
where
go (s, key) =
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Utils.Misc (
mapFst, mapSnd, chkAppend,
mapAndUnzip, mapAndUnzip3, mapAndUnzip4,
- filterOut, partitionWith,
+ filterOut, partitionWith, partitionWithM,
dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,
@@ -219,6 +219,17 @@ partitionWith f (x:xs) = case f x of
Right c -> (bs, c:cs)
where (bs,cs) = partitionWith f xs
+partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])
+-- ^ Monadic version of `partitionWith`
+partitionWithM _ [] = return ([], [])
+partitionWithM f (x:xs) = do
+ y <- f x
+ (bs, cs) <- partitionWithM f xs
+ case y of
+ Left b -> return (b:bs, cs)
+ Right c -> return (bs, c:cs)
+{-# INLINEABLE partitionWithM #-}
+
chkAppend :: [a] -> [a] -> [a]
-- Checks for the second argument being empty
-- Used in situations where that situation is common
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -1332,6 +1332,35 @@ the binary eventlog file by using the ``-l`` option.
.. _rts-options-debugging:
+
+RTS options for Haskell program coverage
+----------------------------------------
+
+When a program is compiled with the :ghc-flag:`-fhpc` flag, then the generated
+code is instrumented with instructions which keep track of which code was executed
+while the program runs. This functionality is implemented in the runtime system
+and can be controlled by the following flags.
+
+.. index::
+ single: RTS options, hpc
+
+.. rts-flag:: --write-tix-file
+
+ :default: enabled
+ :since: 9.10
+
+ By default, the runtime system writes a file ``<program>.tix`` at the end
+ of execution if the executable is compiled with the ``-fhpc`` option.
+ This file is not written if the ``--write-tix-file=no`` option is passed
+ to the runtime system.
+
+ This option is useful if you want to use the functionality provided by the
+ ``Trace.Hpc.Reflect`` module of the
+ `hpc <https://hackage.haskell.org/package/hpc>`__
+ library. These functions allow to inspect the state of the Tix data structures
+ during runtime, so that the executable can write Tix files to disk itself.
+
+
RTS options for hackers, debuggers, and over-interested souls
-------------------------------------------------------------
=====================================
hadrian/src/Hadrian/Oracles/TextFile.hs
=====================================
@@ -82,8 +82,8 @@ lookupDependencies depFile file = do
| otherwise = 1
deps <- fmap (sortOn weigh) <$> lookupValues depFile file
case deps of
- Nothing -> error $ "No dependencies found for file " ++ quote file
- Just [] -> error $ "No source file found for file " ++ quote file
+ Nothing -> error $ "No dependencies found for file " ++ quote file ++ " in " ++ quote depFile
+ Just [] -> error $ "No source file found for file " ++ quote file ++ " in " ++ quote depFile
Just (source : files) -> return (source, files)
-- | Parse a target from a text file, tracking the result. The file is expected
=====================================
libraries/base/GHC/RTS/Flags.hsc
=====================================
@@ -36,6 +36,7 @@ module GHC.RTS.Flags
, TraceFlags (..)
, TickyFlags (..)
, ParFlags (..)
+ , HpcFlags (..)
, IoSubSystem (..)
, getRTSFlags
, getGCFlags
@@ -48,6 +49,7 @@ module GHC.RTS.Flags
, getTraceFlags
, getTickyFlags
, getParFlags
+ , getHpcFlags
) where
#include "Rts.h"
@@ -387,6 +389,17 @@ data ParFlags = ParFlags
, Generic -- ^ @since 4.15.0.0
)
+-- | Parameters pertaining to Haskell program coverage (HPC)
+--
+-- @since 4.22.0.0
+data HpcFlags = HpcFlags
+ { writeTixFile :: Bool
+ -- ^ Controls whether the @<program>.tix@ file should be
+ -- written after the execution of the program.
+ }
+ deriving (Show -- ^ @since 4.22.0.0
+ , Generic -- ^ @since 4.22.0.0
+ )
-- | Parameters of the runtime system
--
-- @since 4.8.0.0
@@ -400,6 +413,7 @@ data RTSFlags = RTSFlags
, traceFlags :: TraceFlags
, tickyFlags :: TickyFlags
, parFlags :: ParFlags
+ , hpcFlags :: HpcFlags
} deriving ( Show -- ^ @since 4.8.0.0
, Generic -- ^ @since 4.15.0.0
)
@@ -417,6 +431,7 @@ getRTSFlags =
<*> getTraceFlags
<*> getTickyFlags
<*> getParFlags
+ <*> getHpcFlags
peekFilePath :: Ptr () -> IO (Maybe FilePath)
peekFilePath ptr
@@ -488,6 +503,14 @@ getParFlags = do
<*> (toBool <$>
(#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool))
+
+getHpcFlags :: IO HpcFlags
+getHpcFlags = do
+ let ptr = (#ptr RTS_FLAGS, HpcFlags) rtsFlagsPtr
+ HpcFlags
+ <$> (toBool <$>
+ (#{peek HPC_FLAGS, writeTixFile} ptr :: IO CBool))
+
getConcFlags :: IO ConcFlags
getConcFlags = do
let ptr = (#ptr RTS_FLAGS, ConcFlags) rtsFlagsPtr
=====================================
rts/Hpc.c
=====================================
@@ -394,7 +394,7 @@ exitHpc(void) {
#else
bool is_subprocess = false;
#endif
- if (!is_subprocess) {
+ if (!is_subprocess && RtsFlags.HpcFlags.writeTixFile) {
FILE *f = __rts_fopen(tixFilename,"w+");
writeTix(f);
}
=====================================
rts/RtsFlags.c
=====================================
@@ -294,6 +294,7 @@ void initRtsFlagsDefaults(void)
RtsFlags.TickyFlags.showTickyStats = false;
RtsFlags.TickyFlags.tickyFile = NULL;
#endif
+ RtsFlags.HpcFlags.writeTixFile = true;
}
static const char *
@@ -549,6 +550,10 @@ usage_text[] = {
" HeapOverflow exception before the exception is thrown again, if",
" the program is still exceeding the heap limit.",
"",
+" --write-tix-file=<yes|no>",
+" Whether to write <program>.tix at the end of execution.",
+" (default: yes)",
+"",
"RTS options may also be specified using the GHCRTS environment variable.",
"",
"Other RTS options may be available for programs compiled a different way.",
@@ -1040,6 +1045,16 @@ error = true;
RtsFlags.GcFlags.nonmovingDenseAllocatorCount = threshold;
}
}
+ else if (strequal("write-tix-file=yes",
+ &rts_argv[arg][2])) {
+ OPTION_UNSAFE;
+ RtsFlags.HpcFlags.writeTixFile = true;
+ }
+ else if (strequal("write-tix-file=no",
+ &rts_argv[arg][2])) {
+ OPTION_UNSAFE;
+ RtsFlags.HpcFlags.writeTixFile = false;
+ }
#if defined(THREADED_RTS)
#if defined(mingw32_HOST_OS)
else if (!strncmp("io-manager-threads",
=====================================
rts/include/rts/Flags.h
=====================================
@@ -281,6 +281,12 @@ typedef struct _PAR_FLAGS {
bool setAffinity; /* force thread affinity with CPUs */
} PAR_FLAGS;
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _HPC_FLAGS {
+ bool writeTixFile; /* Whether the RTS should write a tix
+ file at the end of execution */
+} HPC_FLAGS;
+
/* See Note [Synchronization of flags and base APIs] */
typedef struct _TICKY_FLAGS {
bool showTickyStats;
@@ -301,6 +307,7 @@ typedef struct _RTS_FLAGS {
TRACE_FLAGS TraceFlags;
TICKY_FLAGS TickyFlags;
PAR_FLAGS ParFlags;
+ HPC_FLAGS HpcFlags;
} RTS_FLAGS;
#if defined(COMPILING_RTS_MAIN)
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8957,6 +8957,8 @@ module GHC.RTS.Flags where
numaMask :: GHC.Types.Word}
type GiveGCStats :: *
data GiveGCStats = NoGCStats | CollectGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats
+ type HpcFlags :: *
+ data HpcFlags = HpcFlags {writeTixFile :: GHC.Types.Bool}
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
@@ -8966,7 +8968,7 @@ module GHC.RTS.Flags where
type ProfFlags :: *
data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
type RTSFlags :: *
- data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags}
+ data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
type RtsTime :: *
type RtsTime = GHC.Word.Word64
type TickyFlags :: *
@@ -8977,6 +8979,7 @@ module GHC.RTS.Flags where
getConcFlags :: GHC.Types.IO ConcFlags
getDebugFlags :: GHC.Types.IO DebugFlags
getGCFlags :: GHC.Types.IO GCFlags
+ getHpcFlags :: GHC.Types.IO HpcFlags
getIoManagerFlag :: GHC.Types.IO IoSubSystem
getMiscFlags :: GHC.Types.IO MiscFlags
getParFlags :: GHC.Types.IO ParFlags
@@ -11571,6 +11574,7 @@ instance GHC.Generics.Generic GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.R
instance GHC.Generics.Generic GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Generics.Generic GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS.Flags’
@@ -12048,6 +12052,7 @@ instance GHC.Show.Show GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.RTS.Flag
instance GHC.Show.Show GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Show.Show GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.IoSubSystem -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11735,6 +11735,8 @@ module GHC.RTS.Flags where
numaMask :: GHC.Types.Word}
type GiveGCStats :: *
data GiveGCStats = NoGCStats | CollectGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats
+ type HpcFlags :: *
+ data HpcFlags = HpcFlags {writeTixFile :: GHC.Types.Bool}
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
@@ -11744,7 +11746,7 @@ module GHC.RTS.Flags where
type ProfFlags :: *
data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
type RTSFlags :: *
- data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags}
+ data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
type RtsTime :: *
type RtsTime = GHC.Word.Word64
type TickyFlags :: *
@@ -11755,6 +11757,7 @@ module GHC.RTS.Flags where
getConcFlags :: GHC.Types.IO ConcFlags
getDebugFlags :: GHC.Types.IO DebugFlags
getGCFlags :: GHC.Types.IO GCFlags
+ getHpcFlags :: GHC.Types.IO HpcFlags
getIoManagerFlag :: GHC.Types.IO IoSubSystem
getMiscFlags :: GHC.Types.IO MiscFlags
getParFlags :: GHC.Types.IO ParFlags
@@ -14344,6 +14347,7 @@ instance GHC.Generics.Generic GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.R
instance GHC.Generics.Generic GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Generics.Generic GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS.Flags’
@@ -14814,6 +14818,7 @@ instance GHC.Show.Show GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.RTS.Flag
instance GHC.Show.Show GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Show.Show GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.IoSubSystem -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -9181,6 +9181,8 @@ module GHC.RTS.Flags where
numaMask :: GHC.Types.Word}
type GiveGCStats :: *
data GiveGCStats = NoGCStats | CollectGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats
+ type HpcFlags :: *
+ data HpcFlags = HpcFlags {writeTixFile :: GHC.Types.Bool}
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
@@ -9190,7 +9192,7 @@ module GHC.RTS.Flags where
type ProfFlags :: *
data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
type RTSFlags :: *
- data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags}
+ data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
type RtsTime :: *
type RtsTime = GHC.Word.Word64
type TickyFlags :: *
@@ -9201,6 +9203,7 @@ module GHC.RTS.Flags where
getConcFlags :: GHC.Types.IO ConcFlags
getDebugFlags :: GHC.Types.IO DebugFlags
getGCFlags :: GHC.Types.IO GCFlags
+ getHpcFlags :: GHC.Types.IO HpcFlags
getIoManagerFlag :: GHC.Types.IO IoSubSystem
getMiscFlags :: GHC.Types.IO MiscFlags
getParFlags :: GHC.Types.IO ParFlags
@@ -11840,6 +11843,7 @@ instance GHC.Generics.Generic GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.R
instance GHC.Generics.Generic GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Generics.Generic GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS.Flags’
@@ -12323,6 +12327,7 @@ instance GHC.Show.Show GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.RTS.Flag
instance GHC.Show.Show GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Show.Show GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.IoSubSystem -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8961,6 +8961,8 @@ module GHC.RTS.Flags where
numaMask :: GHC.Types.Word}
type GiveGCStats :: *
data GiveGCStats = NoGCStats | CollectGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats
+ type HpcFlags :: *
+ data HpcFlags = HpcFlags {writeTixFile :: GHC.Types.Bool}
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
@@ -8970,7 +8972,7 @@ module GHC.RTS.Flags where
type ProfFlags :: *
data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
type RTSFlags :: *
- data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags}
+ data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
type RtsTime :: *
type RtsTime = GHC.Word.Word64
type TickyFlags :: *
@@ -8981,6 +8983,7 @@ module GHC.RTS.Flags where
getConcFlags :: GHC.Types.IO ConcFlags
getDebugFlags :: GHC.Types.IO DebugFlags
getGCFlags :: GHC.Types.IO GCFlags
+ getHpcFlags :: GHC.Types.IO HpcFlags
getIoManagerFlag :: GHC.Types.IO IoSubSystem
getMiscFlags :: GHC.Types.IO MiscFlags
getParFlags :: GHC.Types.IO ParFlags
@@ -11575,6 +11578,7 @@ instance GHC.Generics.Generic GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.R
instance GHC.Generics.Generic GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Generics.Generic GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Generics.Generic GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS.Flags’
@@ -12052,6 +12056,7 @@ instance GHC.Show.Show GHC.RTS.Flags.DoHeapProfile -- Defined in ‘GHC.RTS.Flag
instance GHC.Show.Show GHC.RTS.Flags.DoTrace -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GCFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.GiveGCStats -- Defined in ‘GHC.RTS.Flags’
+instance GHC.Show.Show GHC.RTS.Flags.HpcFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.IoSubSystem -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.MiscFlags -- Defined in ‘GHC.RTS.Flags’
instance GHC.Show.Show GHC.RTS.Flags.ParFlags -- Defined in ‘GHC.RTS.Flags’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23309208c6a8e2668ab7168004eeb019d668472e...c7154342aa0ce467c70eece27614e734c9f365ba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23309208c6a8e2668ab7168004eeb019d668472e...c7154342aa0ce467c70eece27614e734c9f365ba
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/20230926/d362db30/attachment-0001.html>
More information about the ghc-commits
mailing list