module GHC.RTS.Flags
( RtsTime
, RtsNat
, RTSFlags (..)
, GiveGCStats (..)
, GCFlags (..)
, ConcFlags (..)
, MiscFlags (..)
, DebugFlags (..)
, DoCostCentres (..)
, CCFlags (..)
, DoHeapProfile (..)
, ProfFlags (..)
, DoTrace (..)
, TraceFlags (..)
, TickyFlags (..)
, getRTSFlags
, getGCFlags
, getConcFlags
, getMiscFlags
, getDebugFlags
, getCCFlags
, getProfFlags
, getTraceFlags
, getTickyFlags
) where
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
type RtsTime = Word64
type RtsNat = Word32
data GiveGCStats
= NoGCStats
| CollectGCStats
| OneLineGCStats
| SummaryGCStats
| VerboseGCStats
deriving (Show)
instance Enum GiveGCStats where
fromEnum NoGCStats = 0
fromEnum CollectGCStats = 1
fromEnum OneLineGCStats = 2
fromEnum SummaryGCStats = 3
fromEnum VerboseGCStats = 4
toEnum 0 = NoGCStats
toEnum 1 = CollectGCStats
toEnum 2 = OneLineGCStats
toEnum 3 = SummaryGCStats
toEnum 4 = VerboseGCStats
toEnum e = error ("invalid enum for GiveGCStats: " ++ show e)
data GCFlags = GCFlags
{ statsFile :: Maybe FilePath
, giveStats :: GiveGCStats
, maxStkSize :: RtsNat
, initialStkSize :: RtsNat
, stkChunkSize :: RtsNat
, stkChunkBufferSize :: RtsNat
, maxHeapSize :: RtsNat
, minAllocAreaSize :: RtsNat
, minOldGenSize :: RtsNat
, heapSizeSuggestion :: RtsNat
, heapSizeSuggestionAuto :: Bool
, oldGenFactor :: Double
, pcFreeHeap :: Double
, generations :: RtsNat
, steps :: RtsNat
, squeezeUpdFrames :: Bool
, compact :: Bool
, compactThreshold :: Double
, sweep :: Bool
, ringBell :: Bool
, frontpanel :: Bool
, idleGCDelayTime :: RtsTime
, doIdleGC :: Bool
, heapBase :: Word
, allocLimitGrace :: Word
} deriving (Show)
data ConcFlags = ConcFlags
{ ctxtSwitchTime :: RtsTime
, ctxtSwitchTicks :: Int
} deriving (Show)
data MiscFlags = MiscFlags
{ tickInterval :: RtsTime
, installSignalHandlers :: Bool
, machineReadable :: Bool
, linkerMemBase :: Word
} deriving (Show)
data DebugFlags = DebugFlags
{ scheduler :: Bool
, interpreter :: Bool
, weak :: Bool
, gccafs :: Bool
, gc :: Bool
, block_alloc :: Bool
, sanity :: Bool
, stable :: Bool
, prof :: Bool
, linker :: Bool
, apply :: Bool
, stm :: Bool
, squeeze :: Bool
, hpc :: Bool
, sparks :: Bool
} deriving (Show)
data DoCostCentres
= CostCentresNone
| CostCentresSummary
| CostCentresVerbose
| CostCentresAll
| CostCentresXML
deriving (Show)
instance Enum DoCostCentres where
fromEnum CostCentresNone = 0
fromEnum CostCentresSummary = 1
fromEnum CostCentresVerbose = 2
fromEnum CostCentresAll = 3
fromEnum CostCentresXML = 4
toEnum 0 = CostCentresNone
toEnum 1 = CostCentresSummary
toEnum 2 = CostCentresVerbose
toEnum 3 = CostCentresAll
toEnum 4 = 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 = 0
fromEnum HeapByCCS = 1
fromEnum HeapByMod = 2
fromEnum HeapByDescr = 4
fromEnum HeapByType = 5
fromEnum HeapByRetainer = 6
fromEnum HeapByLDV = 7
fromEnum HeapByClosureType = 8
toEnum 0 = NoHeapProfiling
toEnum 1 = HeapByCCS
toEnum 2 = HeapByMod
toEnum 4 = HeapByDescr
toEnum 5 = HeapByType
toEnum 6 = HeapByRetainer
toEnum 7 = HeapByLDV
toEnum 8 = HeapByClosureType
toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e)
data ProfFlags = ProfFlags
{ doHeapProfile :: DoHeapProfile
, heapProfileInterval :: RtsTime
, heapProfileIntervalTicks :: Word
, 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 = 0
fromEnum TraceEventLog = 1
fromEnum TraceStderr = 2
toEnum 0 = TraceNone
toEnum 1 = TraceEventLog
toEnum 2 = TraceStderr
toEnum e = error ("invalid enum for DoTrace: " ++ show e)
data TraceFlags = TraceFlags
{ tracing :: DoTrace
, timestamp :: Bool
, traceScheduler :: Bool
, traceGc :: Bool
, sparksSampled :: Bool
, sparksFull :: Bool
, user :: Bool
} 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>")
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 =<< (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr)
<*> (toEnum . fromIntegral <$>
((\hsc_ptr -> peekByteOff hsc_ptr 8) ptr :: IO RtsNat))
<*> (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 48) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 56) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 64) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 72) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 76) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 80) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 84) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 88) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 96) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 100) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 104) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 112) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 120) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 128) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 136) ptr
getConcFlags :: IO ConcFlags
getConcFlags = do
ptr <- getConcFlagsPtr
ConcFlags <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
getMiscFlags :: IO MiscFlags
getMiscFlags = do
ptr <- getMiscFlagsPtr
MiscFlags <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
getDebugFlags :: IO DebugFlags
getDebugFlags = do
ptr <- getDebugFlagsPtr
DebugFlags <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 36) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 48) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 52) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 56) ptr
getCCFlags :: IO CCFlags
getCCFlags = do
ptr <- getCcFlagsPtr
CCFlags <$> (toEnum . fromIntegral
<$> ((\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO RtsNat))
<*> (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
getProfFlags :: IO ProfFlags
getProfFlags = do
ptr <- getProfFlagsPtr
ProfFlags <$> (toEnum <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr)
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 48) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 56) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 64) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 72) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 80) ptr)
<*> (peekCStringOpt =<< (\hsc_ptr -> peekByteOff hsc_ptr 88) ptr)
getTraceFlags :: IO TraceFlags
getTraceFlags = do
ptr <- getTraceFlagsPtr
TraceFlags <$> (toEnum . fromIntegral
<$> ((\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO CInt))
<*> (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
getTickyFlags :: IO TickyFlags
getTickyFlags = do
ptr <- getTickyFlagsPtr
TickyFlags <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
<*> (peekFilePath =<< (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr)