accessors to RTS flag values -- #5364

Summary: Implementation of #5364. Mostly boilerplate, reading FILE fields is missing.

Test Plan:
- Get some feedback on missing parts. (FILE fields)
- Get some feedback on module name.
- Get some feedback on other things.
- Get code reviewed.
- Make sure test suite is passing. (I haven't run it myself)

Reviewers: hvr, austin, ezyang

Reviewed By: ezyang

Subscribers: ekmett, simonmar, ezyang, carter, thomie

Differential Revision: https://phabricator.haskell.org/D306

GHC Trac Issues: #5364

Conflicts:
	includes/rts/Flags.h

1 files changed, 408 insertions, 0 deletions

diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc
new file mode 100644
index 0000000000..1d75568061
--- /dev/null
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -0,0 +1,408 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | Accessors to GHC RTS flags.
+-- Descriptions of flags can be seen in
+-- <https://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html GHC User's Guide>,
+-- or by running RTS help message using @+RTS --help@.
+--
+-- /Since: 4.8.0.0/
+--
+module GHC.RTS.Flags
+  ( RTSFlags (..)
+  , GCFlags (..)
+  , ConcFlags (..)
+  , MiscFlags (..)
+  , DebugFlags (..)
+  , CCFlags (..)
+  , ProfFlags (..)
+  , TraceFlags (..)
+  , TickyFlags (..)
+  , getRTSFlags
+  , getGCFlags
+  , getConcFlags
+  , getMiscFlags
+  , getDebugFlags
+  , getCCFlags
+  , getProfFlags
+  , getTraceFlags
+  , getTickyFlags
+  ) where
+
+#include "Rts.h"
+#include "rts/Flags.h"
+
+import Control.Applicative
+import Control.Monad
+
+import Foreign.C.String    (peekCString)
+import Foreign.C.Types     (CChar, CInt)
+import Foreign.Ptr         (Ptr, nullPtr)
+import Foreign.Storable    (peekByteOff)
+
+import GHC.Base
+import GHC.Enum
+import GHC.IO
+import GHC.Real
+import GHC.Show
+import GHC.Word
+
+-- | @'Time'@ is defined as a @'StgWord64'@ in @stg/Types.h@
+type Time = Word64
+
+-- | @'nat'@ defined in @rts/Types.h@
+type Nat = #{type unsigned int}
+
+data GiveGCStats
+    = NoGCStats
+    | CollectGCStats
+    | OneLineGCStats
+    | SummaryGCStats
+    | VerboseGCStats
+    deriving (Show)
+
+instance Enum GiveGCStats where
+    fromEnum NoGCStats      = #{const NO_GC_STATS}
+    fromEnum CollectGCStats = #{const COLLECT_GC_STATS}
+    fromEnum OneLineGCStats = #{const ONELINE_GC_STATS}
+    fromEnum SummaryGCStats = #{const SUMMARY_GC_STATS}
+    fromEnum VerboseGCStats = #{const VERBOSE_GC_STATS}
+
+    toEnum #{const NO_GC_STATS}      = NoGCStats
+    toEnum #{const COLLECT_GC_STATS} = CollectGCStats
+    toEnum #{const ONELINE_GC_STATS} = OneLineGCStats
+    toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats
+    toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats
+    toEnum e = error ("invalid enum for GiveGCStats: " ++ show e)
+
+data GCFlags = GCFlags
+    { statsFile             :: Maybe FilePath
+    , giveStats             :: GiveGCStats
+    , maxStkSize            :: Nat
+    , initialStkSize        :: Nat
+    , stkChunkSize          :: Nat
+    , stkChunkBufferSize    :: Nat
+    , maxHeapSize           :: Nat
+    , minAllocAreaSize      :: Nat
+    , minOldGenSize         :: Nat
+    , heapSizeSuggestion    :: Nat
+    , heapSizeSuggesionAuto :: Bool
+    , oldGenFactor          :: Double
+    , pcFreeHeap            :: Double
+    , generations           :: Nat
+    , steps                 :: Nat
+    , squeezeUpdFrames      :: Bool
+    , compact               :: Bool -- ^ True <=> "compact all the time"
+    , compactThreshold      :: Double
+    , sweep                 :: Bool
+      -- ^ use "mostly mark-sweep" instead of copying for the oldest generation
+    , ringBell              :: Bool
+    , frontpanel            :: Bool
+    , idleGCDelayTime       :: Time
+    , doIdleGC              :: Bool
+    , heapBase              :: Word -- ^ address to ask the OS for memory
+    , allocLimitGrace       :: Word
+    } deriving (Show)
+
+data ConcFlags = ConcFlags
+    { ctxtSwitchTime  :: Time
+    , ctxtSwitchTicks :: Int
+    } deriving (Show)
+
+data MiscFlags = MiscFlags
+    { tickInterval          :: Time
+    , installSignalHandlers :: Bool
+    , machineReadable       :: Bool
+    , linkerMemBase         :: Word
+      -- ^ address to ask the OS for memory for the linker, 0 ==> off
+    } deriving (Show)
+
+-- | Flags to control debugging output & extra checking in various
+-- subsystems.
+data DebugFlags = DebugFlags
+    { scheduler   :: Bool -- ^ 's'
+    , interpreter :: Bool -- ^ 'i'
+    , weak        :: Bool -- ^ 'w'
+    , gccafs      :: Bool -- ^ 'G'
+    , gc          :: Bool -- ^ 'g'
+    , block_alloc :: Bool -- ^ 'b'
+    , sanity      :: Bool -- ^ 'S'
+    , stable      :: Bool -- ^ 't'
+    , prof        :: Bool -- ^ 'p'
+    , linker      :: Bool -- ^ 'l' the object linker
+    , apply       :: Bool -- ^ 'a'
+    , stm         :: Bool -- ^ 'm'
+    , squeeze     :: Bool -- ^ 'z' stack squeezing & lazy blackholing
+    , hpc         :: Bool -- ^ 'c' coverage
+    , sparks      :: Bool -- ^ 'r'
+    } deriving (Show)
+
+data DoCostCentres
+    = CostCentresNone
+    | CostCentresSummary
+    | CostCentresVerbose
+    | CostCentresAll
+    | CostCentresXML
+    deriving (Show)
+
+instance Enum DoCostCentres where
+    fromEnum CostCentresNone    = #{const COST_CENTRES_NONE}
+    fromEnum CostCentresSummary = #{const COST_CENTRES_SUMMARY}
+    fromEnum CostCentresVerbose = #{const COST_CENTRES_VERBOSE}
+    fromEnum CostCentresAll     = #{const COST_CENTRES_ALL}
+    fromEnum CostCentresXML     = #{const COST_CENTRES_XML}
+
+    toEnum #{const COST_CENTRES_NONE}    = CostCentresNone
+    toEnum #{const COST_CENTRES_SUMMARY} = CostCentresSummary
+    toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose
+    toEnum #{const COST_CENTRES_ALL}     = CostCentresAll
+    toEnum #{const COST_CENTRES_XML}     = CostCentresXML
+    toEnum e = error ("invalid enum for DoCostCentres: " ++ show e)
+
+data CCFlags = CCFlags
+    { doCostCentres :: DoCostCentres
+    , profilerTicks :: Int
+    , msecsPerTick  :: Int
+    } deriving (Show)
+
+data DoHeapProfile
+    = NoHeapProfiling
+    | HeapByCCS
+    | HeapByMod
+    | HeapByDescr
+    | HeapByType
+    | HeapByRetainer
+    | HeapByLDV
+    | HeapByClosureType
+    deriving (Show)
+
+instance Enum DoHeapProfile where
+    fromEnum NoHeapProfiling   = #{const NO_HEAP_PROFILING}
+    fromEnum HeapByCCS         = #{const HEAP_BY_CCS}
+    fromEnum HeapByMod         = #{const HEAP_BY_MOD}
+    fromEnum HeapByDescr       = #{const HEAP_BY_DESCR}
+    fromEnum HeapByType        = #{const HEAP_BY_TYPE}
+    fromEnum HeapByRetainer    = #{const HEAP_BY_RETAINER}
+    fromEnum HeapByLDV         = #{const HEAP_BY_LDV}
+    fromEnum HeapByClosureType = #{const HEAP_BY_CLOSURE_TYPE}
+
+    toEnum #{const NO_HEAP_PROFILING}    = NoHeapProfiling
+    toEnum #{const HEAP_BY_CCS}          = HeapByCCS
+    toEnum #{const HEAP_BY_MOD}          = HeapByMod
+    toEnum #{const HEAP_BY_DESCR}        = HeapByDescr
+    toEnum #{const HEAP_BY_TYPE}         = HeapByType
+    toEnum #{const HEAP_BY_RETAINER}     = HeapByRetainer
+    toEnum #{const HEAP_BY_LDV}          = HeapByLDV
+    toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType
+    toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e)
+
+data ProfFlags = ProfFlags
+    { doHeapProfile            :: DoHeapProfile
+    , heapProfileInterval      :: Time -- ^ time between samples
+    , heapProfileIntervalTicks :: Word -- ^ ticks between samples (derived)
+    , includeTSOs              :: Bool
+    , showCCSOnException       :: Bool
+    , maxRetainerSetSize       :: Word
+    , ccsLength                :: Word
+    , modSelector              :: Maybe String
+    , descrSelector            :: Maybe String
+    , typeSelector             :: Maybe String
+    , ccSelector               :: Maybe String
+    , ccsSelector              :: Maybe String
+    , retainerSelector         :: Maybe String
+    , bioSelector              :: Maybe String
+    } deriving (Show)
+
+data DoTrace
+    = TraceNone
+    | TraceEventLog
+    | TraceStderr
+    deriving (Show)
+
+instance Enum DoTrace where
+    fromEnum TraceNone     = #{const TRACE_NONE}
+    fromEnum TraceEventLog = #{const TRACE_EVENTLOG}
+    fromEnum TraceStderr   = #{const TRACE_STDERR}
+
+    toEnum #{const TRACE_NONE}     = TraceNone
+    toEnum #{const TRACE_EVENTLOG} = TraceEventLog
+    toEnum #{const TRACE_STDERR}   = TraceStderr
+    toEnum e = error ("invalid enum for DoTrace: " ++ show e)
+
+data TraceFlags = TraceFlags
+    { tracing        :: DoTrace
+    , timestamp      :: Bool -- ^ show timestamp in stderr output
+    , traceScheduler :: Bool -- ^ trace scheduler events
+    , traceGc        :: Bool -- ^ trace GC events
+    , sparksSampled  :: Bool -- ^ trace spark events by a sampled method
+    , sparksFull     :: Bool -- ^ trace spark events 100% accurately
+    , user           :: Bool -- ^ trace user events (emitted from Haskell code)
+    } deriving (Show)
+
+data TickyFlags = TickyFlags
+    { showTickyStats :: Bool
+    , tickyFile      :: Maybe FilePath
+    } deriving (Show)
+
+data RTSFlags = RTSFlags
+    { gcFlags         :: GCFlags
+    , concurrentFlags :: ConcFlags
+    , miscFlags       :: MiscFlags
+    , debugFlags      :: DebugFlags
+    , costCentreFlags :: CCFlags
+    , profilingFlags  :: ProfFlags
+    , traceFlags      :: TraceFlags
+    , tickyFlags      :: TickyFlags
+    } deriving (Show)
+
+foreign import ccall safe "getGcFlags"
+  getGcFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getConcFlags"
+  getConcFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getMiscFlags"
+  getMiscFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getDebugFlags"
+  getDebugFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getCcFlags"
+  getCcFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getProfFlags" getProfFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getTraceFlags"
+  getTraceFlagsPtr :: IO (Ptr ())
+
+foreign import ccall safe "getTickyFlags"
+  getTickyFlagsPtr :: IO (Ptr ())
+
+getRTSFlags :: IO RTSFlags
+getRTSFlags = do
+  RTSFlags <$> getGCFlags
+           <*> getConcFlags
+           <*> getMiscFlags
+           <*> getDebugFlags
+           <*> getCCFlags
+           <*> getProfFlags
+           <*> getTraceFlags
+           <*> getTickyFlags
+
+peekFilePath :: Ptr () -> IO (Maybe FilePath)
+peekFilePath ptr
+  | ptr == nullPtr = return Nothing
+  | otherwise      = return (Just "<filepath>")
+
+-- | Read a NUL terminated string. Return Nothing in case of a NULL pointer.
+peekCStringOpt :: Ptr CChar -> IO (Maybe String)
+peekCStringOpt ptr
+  | ptr == nullPtr = return Nothing
+  | otherwise      = Just <$> peekCString ptr
+
+getGCFlags :: IO GCFlags
+getGCFlags = do
+  ptr <- getGcFlagsPtr
+  GCFlags <$> (peekFilePath =<< #{peek GC_FLAGS, statsFile} ptr)
+          <*> (toEnum . fromIntegral <$>
+                (#{peek GC_FLAGS, giveStats} ptr :: IO Nat))
+          <*> #{peek GC_FLAGS, maxStkSize} ptr
+          <*> #{peek GC_FLAGS, initialStkSize} ptr
+          <*> #{peek GC_FLAGS, stkChunkSize} ptr
+          <*> #{peek GC_FLAGS, stkChunkBufferSize} ptr
+          <*> #{peek GC_FLAGS, maxHeapSize} ptr
+          <*> #{peek GC_FLAGS, minAllocAreaSize} ptr
+          <*> #{peek GC_FLAGS, minOldGenSize} ptr
+          <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr
+          <*> #{peek GC_FLAGS, heapSizeSuggestionAuto} ptr
+          <*> #{peek GC_FLAGS, oldGenFactor} ptr
+          <*> #{peek GC_FLAGS, pcFreeHeap} ptr
+          <*> #{peek GC_FLAGS, generations} ptr
+          <*> #{peek GC_FLAGS, steps} ptr
+          <*> #{peek GC_FLAGS, squeezeUpdFrames} ptr
+          <*> #{peek GC_FLAGS, compact} ptr
+          <*> #{peek GC_FLAGS, compactThreshold} ptr
+          <*> #{peek GC_FLAGS, sweep} ptr
+          <*> #{peek GC_FLAGS, ringBell} ptr
+          <*> #{peek GC_FLAGS, frontpanel} ptr
+          <*> #{peek GC_FLAGS, idleGCDelayTime} ptr
+          <*> #{peek GC_FLAGS, doIdleGC} ptr
+          <*> #{peek GC_FLAGS, heapBase} ptr
+          <*> #{peek GC_FLAGS, allocLimitGrace} ptr
+
+getConcFlags :: IO ConcFlags
+getConcFlags = do
+  ptr <- getConcFlagsPtr
+  ConcFlags <$> #{peek CONCURRENT_FLAGS, ctxtSwitchTime} ptr
+            <*> #{peek CONCURRENT_FLAGS, ctxtSwitchTicks} ptr
+
+getMiscFlags :: IO MiscFlags
+getMiscFlags = do
+  ptr <- getMiscFlagsPtr
+  MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
+            <*> #{peek MISC_FLAGS, install_signal_handlers} ptr
+            <*> #{peek MISC_FLAGS, machineReadable} ptr
+            <*> #{peek MISC_FLAGS, linkerMemBase} ptr
+
+getDebugFlags :: IO DebugFlags
+getDebugFlags = do
+  ptr <- getDebugFlagsPtr
+  DebugFlags <$> #{peek DEBUG_FLAGS, scheduler} ptr
+             <*> #{peek DEBUG_FLAGS, interpreter} ptr
+             <*> #{peek DEBUG_FLAGS, weak} ptr
+             <*> #{peek DEBUG_FLAGS, gccafs} ptr
+             <*> #{peek DEBUG_FLAGS, gc} ptr
+             <*> #{peek DEBUG_FLAGS, block_alloc} ptr
+             <*> #{peek DEBUG_FLAGS, sanity} ptr
+             <*> #{peek DEBUG_FLAGS, stable} ptr
+             <*> #{peek DEBUG_FLAGS, prof} ptr
+             <*> #{peek DEBUG_FLAGS, linker} ptr
+             <*> #{peek DEBUG_FLAGS, apply} ptr
+             <*> #{peek DEBUG_FLAGS, stm} ptr
+             <*> #{peek DEBUG_FLAGS, squeeze} ptr
+             <*> #{peek DEBUG_FLAGS, hpc} ptr
+             <*> #{peek DEBUG_FLAGS, sparks} ptr
+
+getCCFlags :: IO CCFlags
+getCCFlags = do
+  ptr <- getCcFlagsPtr
+  CCFlags <$> (toEnum . fromIntegral
+                <$> (#{peek COST_CENTRE_FLAGS, doCostCentres} ptr :: IO Nat))
+          <*> #{peek COST_CENTRE_FLAGS, profilerTicks} ptr
+          <*> #{peek COST_CENTRE_FLAGS, msecsPerTick} ptr
+
+getProfFlags :: IO ProfFlags
+getProfFlags = do
+  ptr <- getProfFlagsPtr
+  ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr)
+            <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr
+            <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr
+            <*> #{peek PROFILING_FLAGS, includeTSOs} ptr
+            <*> #{peek PROFILING_FLAGS, showCCSOnException} ptr
+            <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr
+            <*> #{peek PROFILING_FLAGS, ccsLength} ptr
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, descrSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, typeSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccsSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, retainerSelector} ptr)
+            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, bioSelector} ptr)
+
+getTraceFlags :: IO TraceFlags
+getTraceFlags = do
+  ptr <- getTraceFlagsPtr
+  TraceFlags <$> (toEnum . fromIntegral
+                   <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt))
+             <*> #{peek TRACE_FLAGS, timestamp} ptr
+             <*> #{peek TRACE_FLAGS, scheduler} ptr
+             <*> #{peek TRACE_FLAGS, gc} ptr
+             <*> #{peek TRACE_FLAGS, sparks_sampled} ptr
+             <*> #{peek TRACE_FLAGS, sparks_full} ptr
+             <*> #{peek TRACE_FLAGS, user} ptr
+
+getTickyFlags :: IO TickyFlags
+getTickyFlags = do
+  ptr <- getTickyFlagsPtr
+  TickyFlags <$> #{peek TICKY_FLAGS, showTickyStats} ptr
+             <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr)