diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index 847c6c13949732730bf1af01a07de230acc13317..489b3c23a435057c335977e6b3a6ee1dacddb726 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 c236cdd07f8fdf43dd6721575cbb3e8c2112d95f..e885b60308c882b523bf5d7819c171ac61d6ebd8 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 ffc531b16259f2a4e743a8d83fddea437fb9aa8e..56e5c59233eee1f5fbda4afc437c58385275f662 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 cd67935e3caa43929260cc4290ec41f31bcdda79..b31e873706b2a4bfbe5b9d5a7870233794ce9538 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)