From f1e5245a39ca89a8173ae0b49af4405454a1f9bd Mon Sep 17 00:00:00 2001
From: David Binder <david.binder@uni-tuebingen.de>
Date: Fri, 15 Sep 2023 17:37:13 +0200
Subject: [PATCH] Add RTS option to supress tix file
---
libraries/base/GHC/RTS/Flags.hsc | 13 +++++++++++++
rts/Hpc.c | 2 +-
rts/RtsFlags.c | 6 ++++++
rts/include/rts/Flags.h | 7 +++++++
4 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc
index 847c6c139497..489b3c23a435 100644
--- a/libraries/base/GHC/RTS/Flags.hsc
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -387,6 +387,13 @@ data ParFlags = ParFlags
, Generic -- ^ @since 4.15.0.0
)
+-- | Parameters pertaining to Haskell program coverage (HPC)
+data HpcFlags = HpcFlags
+ { emitTixFile :: Bool
+ }
+ deriving (Show
+ , Generic
+ )
-- | Parameters of the runtime system
--
-- @since 4.8.0.0
@@ -400,6 +407,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 +425,7 @@ getRTSFlags =
<*> getTraceFlags
<*> getTickyFlags
<*> getParFlags
+ <*> getHpcFlags
peekFilePath :: Ptr () -> IO (Maybe FilePath)
peekFilePath ptr
@@ -488,6 +497,10 @@ getParFlags = do
<*> (toBool <$>
(#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool))
+
+getHpcFlags :: IO HpcFlags
+getHpcFlags = error "TODO: Implement getHpcFlags"
+
getConcFlags :: IO ConcFlags
getConcFlags = do
let ptr = (#ptr RTS_FLAGS, ConcFlags) rtsFlagsPtr
diff --git a/rts/Hpc.c b/rts/Hpc.c
index c236cdd07f8f..e885b60308c8 100644
--- a/rts/Hpc.c
+++ b/rts/Hpc.c
@@ -394,7 +394,7 @@ exitHpc(void) {
#else
bool is_subprocess = false;
#endif
- if (!is_subprocess) {
+ if (!is_subprocess && RtsFlags.HpcFlags.emitTixFile) {
FILE *f = __rts_fopen(tixFilename,"w+");
writeTix(f);
}
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index ffc531b16259..56e5c59233ee 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -294,6 +294,7 @@ void initRtsFlagsDefaults(void)
RtsFlags.TickyFlags.showTickyStats = false;
RtsFlags.TickyFlags.tickyFile = NULL;
#endif
+ RtsFlags.HpcFlags.emitTixFile = true;
}
static const char *
@@ -1040,6 +1041,11 @@ error = true;
RtsFlags.GcFlags.nonmovingDenseAllocatorCount = threshold;
}
}
+ else if (strequal("emit-tix-file=false",
+ &rts_argv[arg][2])) {
+ OPTION_UNSAFE;
+ RtsFlags.HpcFlags.emitTixFile = false;
+ }
#if defined(THREADED_RTS)
#if defined(mingw32_HOST_OS)
else if (!strncmp("io-manager-threads",
diff --git a/rts/include/rts/Flags.h b/rts/include/rts/Flags.h
index cd67935e3caa..b31e873706b2 100644
--- a/rts/include/rts/Flags.h
+++ b/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 emitTixFile; /* 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)
--
GitLab