[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Add RTS option to supress tix file
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 27 02:48:25 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cd02c020 by David Binder at 2023-09-26T22:48:11-04:00
Add RTS option to supress tix file
- - - - -
df396041 by David Binder at 2023-09-26T22:48:12-04:00
Add expected output to testsuite in test interface-stability/base-exports
- - - - -
cc1656d0 by David Binder at 2023-09-26T22:48:12-04:00
Expose HpcFlags and getHpcFlags from GHC.RTS.Flags
- - - - -
c02b3e24 by David Binder at 2023-09-26T22:48:12-04:00
Fix expected output of interface-stability test
- - - - -
c689f0b8 by David Binder at 2023-09-26T22:48:12-04:00
Implement getHpcFlags
- - - - -
da291b66 by David Binder at 2023-09-26T22:48:12-04:00
Add section in user guide
- - - - -
c26bf4f5 by David Binder at 2023-09-26T22:48:12-04:00
Rename --emit-tix-file to --write-tix-file
- - - - -
060c0fe1 by David Binder at 2023-09-26T22:48:12-04:00
Update the golden files for interface stability
- - - - -
c069e94d by Krzysztof Gogolewski at 2023-09-26T22:48:12-04:00
Refactor: introduce stgArgRep
The function 'stgArgType' returns the type in STG. But this violates
the abstraction: in STG we're supposed to operate on PrimReps.
This introduces
stgArgRep ty = typePrimRep (stgArgType ty)
stgArgRep1 ty = typePrimRep1 (stgArgType ty)
stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)
stgArgType is still directly used for unboxed tuples (should be fixable), FFI
and in ticky.
- - - - -
20 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/Types/RepType.hs
- docs/users_guide/runtime_control.rst
- 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:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -602,7 +602,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)
arg' = getStgArgFromTrivialArg arg
arg_rep = typePrimRep arg_ty
- stg_arg_rep = typePrimRep (stgArgType arg')
+ stg_arg_rep = stgArgRep arg'
bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -178,7 +178,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
lintStgConArg :: StgArg -> LintM ()
lintStgConArg arg = do
unarised <- lf_unarised <$> getLintFlags
- when unarised $ case typePrimRep_maybe (stgArgType arg) of
+ when unarised $ case stgArgRep_maybe arg of
-- Note [Post-unarisation invariants], invariant 4
Just [_] -> pure ()
badRep -> addErrL $
@@ -192,7 +192,7 @@ lintStgConArg arg = do
lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg arg = do
unarised <- lf_unarised <$> getLintFlags
- when unarised $ case typePrimRep_maybe (stgArgType arg) of
+ when unarised $ case stgArgRep_maybe arg of
-- Note [Post-unarisation invariants], invariant 3
Just [] -> pure ()
Just [_] -> pure ()
@@ -371,7 +371,7 @@ lintStgAppReps fun args = do
-- and we abort kind checking.
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
- actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
+ actual_arg_reps = map stgArgRep_maybe args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args (Nothing:_) _ = return ()
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -56,6 +56,10 @@ module GHC.Stg.Syntax (
stgRhsArity, freeVarsOfRhs,
isDllConApp,
stgArgType,
+ stgArgRep,
+ stgArgRep1,
+ stgArgRep_maybe,
+
stgCaseBndrInScope,
-- ppr
@@ -86,7 +90,7 @@ import GHC.Types.Name ( isDynLinkName )
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
-import GHC.Types.RepType ( typePrimRep1, typePrimRep )
+import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe )
import GHC.Unit.Module ( Module )
import GHC.Utils.Outputable
@@ -181,15 +185,30 @@ isAddrRep _ = False
-- | Type of an @StgArg@
--
-- Very half baked because we have lost the type arguments.
+--
+-- This function should be avoided: in STG we aren't supposed to
+-- look at types, but only PrimReps.
+-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed.
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v) = idType v
stgArgType (StgLitArg lit) = literalType lit
+stgArgRep :: StgArg -> [PrimRep]
+stgArgRep ty = typePrimRep (stgArgType ty)
+
+stgArgRep_maybe :: StgArg -> Maybe [PrimRep]
+stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)
+
+-- | Assumes that the argument has one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
+stgArgRep1 :: StgArg -> PrimRep
+stgArgRep1 ty = typePrimRep1 (stgArgType ty)
+
-- | Given an alt type and whether the program is unarised, return whether the
-- case binder is in scope.
--
-- Case binders of unboxed tuple or unboxed sum type always dead after the
--- unariser has run. See Note [Post-unarisation invariants].
+-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
stgCaseBndrInScope alt_ty unarised =
case alt_ty of
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -446,10 +446,10 @@ instance Outputable UnariseVal where
-- See Note [UnariseEnv]
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho env x (MultiVal args)
- = assert (all (isNvUnaryType . stgArgType) args)
+ = assert (all (isNvUnaryRep . stgArgRep) args)
env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
extendRho env x (UnaryVal val)
- = assert (isNvUnaryType (stgArgType val))
+ = assert (isNvUnaryRep (stgArgRep val))
env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
-- Properly shadow things from an outer scope.
-- See Note [UnariseEnv]
@@ -745,7 +745,7 @@ mapTupleIdBinders
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders ids args0 rho0
- = assert (not (any (isZeroBitTy . stgArgType) args0)) $
+ = assert (not (any (null . stgArgRep) args0)) $
let
ids_unarised :: [(Id, [PrimRep])]
ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
@@ -779,13 +779,13 @@ mapSumIdBinders
-> UniqSM (UnariseEnv, OutStgExpr)
mapSumIdBinders alt_bndr args rhs rho0
- = assert (not (any (isZeroBitTy . stgArgType) args)) $ do
+ = assert (not (any (null . stgArgRep) args)) $ do
uss <- listSplitUniqSupply <$> getUniqueSupplyM
let
fld_reps = typePrimRep (idType alt_bndr)
-- Slots representing the whole sum
- arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+ arg_slots = map primRepSlot $ concatMap stgArgRep args
-- The slots representing the field of the sum we bind.
id_slots = map primRepSlot $ fld_reps
layout1 = layoutUbxSum arg_slots id_slots
@@ -879,7 +879,7 @@ mkUbxSum dc ty_args args0 us
= let
_ :| sum_slots = ubxSumRepType (map typePrimRep ty_args)
-- drop tag slot
- field_slots = (mapMaybe (typeSlotTy . stgArgType) args0)
+ field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
tag = dataConTag dc
layout' = layoutUbxSum sum_slots field_slots
@@ -912,9 +912,9 @@ mkUbxSum dc ty_args args0 us
castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
castArg us slot_ty arg
-- Cast the argument to the type of the slot if required
- | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg)
+ | slotPrimRep slot_ty /= stgArgRep1 arg
, out_ty <- primRepToType $ slotPrimRep slot_ty
- , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty
+ , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty
, not . null $ ops
= let (us1,us2) = splitUniqSupply us
cast_uqs = uniqsFromSupply us1
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep )
+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
@@ -1385,16 +1385,16 @@ generatePrimCall d s p target _mb_unit _result_ty args
non_void _ = True
nv_args :: [StgArg]
- nv_args = filter (non_void . argPrimRep) args
+ nv_args = filter (non_void . stgArgRep1) args
(args_info, args_offsets) =
layoutNativeCall profile
NativePrimCall
0
- (primRepCmmType platform . argPrimRep)
+ (primRepCmmType platform . stgArgRep1)
nv_args
- prim_args_offsets = mapFst argPrimRep args_offsets
+ prim_args_offsets = mapFst stgArgRep1 args_offsets
shifted_args_offsets = mapSnd (+ d) args_offsets
push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -19,7 +19,6 @@ module GHC.StgToCmm.Closure (
DynTag, tagForCon, isSmallFamily,
idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
- argPrimRep,
NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
assertNonVoidIds, assertNonVoidStgArgs,
@@ -161,13 +160,13 @@ assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $
coerce ids
nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (null (stgArgRep arg))]
-- | Used in places where some invariant ensures that all these arguments are
-- non-void; e.g. constructor arguments.
-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
+assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $
coerce args
@@ -179,27 +178,22 @@ assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
-- holds after unarise.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep1 (idType id)
-- See also Note [VoidRep] in GHC.Types.RepType
-- | Assumes that Ids have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps = map (\id -> let id' = fromNonVoid id
in NonVoid (idPrimRep id', id'))
-- | Assumes that arguments have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps = map (\arg -> let arg' = fromNonVoid arg
- in NonVoid (argPrimRep arg', arg'))
-
--- | Assumes that the argument has one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep1 (stgArgType arg)
+ in NonVoid (stgArgRep1 arg', arg'))
------------------------------------------------------
-- Building LambdaFormInfo
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1001,7 +1001,7 @@ cgIdApp fun_id args = do
fun = idInfoToAmode fun_info
lf_info = cg_lf fun_info
n_args = length args
- v_args = length $ filter (isZeroBitTy . stgArgType) args
+ v_args = length $ filter (null . stgArgRep) args
case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of
-- A value in WHNF, so we can just return it.
ReturnIt
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -331,7 +331,7 @@ getArgRepsAmodes args = do
| V <- rep = return (V, Nothing)
| otherwise = do expr <- getArgAmode (NonVoid arg)
return (rep, Just expr)
- where rep = toArgRep platform (argPrimRep arg)
+ where rep = toArgRep platform (stgArgRep1 arg)
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
@@ -605,7 +605,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- so the result list may be shorter than the argument list
getNonVoidArgAmodes [] = return []
getNonVoidArgAmodes (arg:args)
- | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+ | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args
| otherwise = do { amode <- getArgAmode (NonVoid arg)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| args `lengthIs` arity = tickyKnownCallExact
| otherwise = do tickyKnownCallExtraArgs
- tickySlowCallPat (map argPrimRep (drop arity args))
+ tickySlowCallPat (map stgArgRep1 (drop arity args))
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
@@ -610,7 +610,7 @@ tickySlowCall lf_info args = do
if isKnownFun lf_info
then tickyKnownCallTooFewArgs
else tickyUnknownCall
- tickySlowCallPat (map argPrimRep args)
+ tickySlowCallPat (map stgArgRep1 args)
tickySlowCallPat :: [PrimRep] -> FCode ()
tickySlowCallPat args = ifTicky $ do
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -118,7 +118,7 @@ genStaticArg a = case a of
Nothing -> reg
Just expr -> unfloated expr
where
- r = unaryTypeJSRep . stgArgType $ a
+ r = primRepToJSRep $ stgArgRep1 a
reg
| isVoid r =
return []
@@ -160,7 +160,7 @@ genArg a = case a of
where
-- if our argument is a joinid, it can be an unboxed tuple
r :: HasDebugCallStack => JSRep
- r = unaryTypeJSRep . stgArgType $ a
+ r = primRepToJSRep $ stgArgRep1 a
unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
unfloated = \case
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -4,7 +4,7 @@
module GHC.Types.RepType
(
-- * Code generator views onto Types
- UnaryType, NvUnaryType, isNvUnaryType,
+ UnaryType, NvUnaryType, isNvUnaryRep,
unwrapType,
-- * Predicates on types
@@ -19,7 +19,7 @@ module GHC.Types.RepType
runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,
-- * Unboxed sum representation type
- ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
+ ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),
slotPrimRep, primRepSlot,
-- * Is this type known to be data?
@@ -76,12 +76,9 @@ type UnaryType = Type
-- UnaryType : never an unboxed tuple or sum;
-- can be Void# or (# #)
-isNvUnaryType :: Type -> Bool
-isNvUnaryType ty
- | [_] <- typePrimRep ty
- = True
- | otherwise
- = False
+isNvUnaryRep :: [PrimRep] -> Bool
+isNvUnaryRep [_] = True
+isNvUnaryRep _ = False
-- INVARIANT: the result list is never empty.
typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep
@@ -307,11 +304,11 @@ instance Outputable SlotTy where
ppr FloatSlot = text "FloatSlot"
ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e
-typeSlotTy :: UnaryType -> Maybe SlotTy
-typeSlotTy ty = case typePrimRep ty of
+repSlotTy :: [PrimRep] -> Maybe SlotTy
+repSlotTy reps = case reps of
[] -> Nothing
[rep] -> Just (primRepSlot rep)
- reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)
+ _ -> pprPanic "repSlotTy" (ppr reps)
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
=====================================
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
-------------------------------------------------------------
=====================================
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/c7154342aa0ce467c70eece27614e734c9f365ba...c069e94d4274f589abc43f429226e07284e407c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7154342aa0ce467c70eece27614e734c9f365ba...c069e94d4274f589abc43f429226e07284e407c5
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/55984d2c/attachment-0001.html>
More information about the ghc-commits
mailing list