Switch VEH to VCH and allow disabling of SEH completely.
[ghc.git] / libraries / base / GHC / RTS / Flags.hsc
1 {-# LANGUAGE NoImplicitPrelude #-}
2 {-# LANGUAGE RecordWildCards   #-}
3
4 -- | Accessors to GHC RTS flags.
5 -- Descriptions of flags can be seen in
6 -- <https://www.haskell.org/ghc/docs/latest/html/users_guide/runtime_control.html GHC User's Guide>,
7 -- or by running RTS help message using @+RTS --help@.
8 --
9 -- @since 4.8.0.0
10 --
11 module GHC.RTS.Flags
12   ( RtsTime
13   , RTSFlags (..)
14   , GiveGCStats (..)
15   , GCFlags (..)
16   , ConcFlags (..)
17   , MiscFlags (..)
18   , DebugFlags (..)
19   , DoCostCentres (..)
20   , CCFlags (..)
21   , DoHeapProfile (..)
22   , ProfFlags (..)
23   , DoTrace (..)
24   , TraceFlags (..)
25   , TickyFlags (..)
26   , ParFlags (..)
27   , getRTSFlags
28   , getGCFlags
29   , getConcFlags
30   , getMiscFlags
31   , getDebugFlags
32   , getCCFlags
33   , getProfFlags
34   , getTraceFlags
35   , getTickyFlags
36   , getParFlags
37   ) where
38
39 #include "Rts.h"
40 #include "rts/Flags.h"
41
42 import Control.Applicative
43 import Control.Monad
44
45 import Foreign
46 import Foreign.C
47
48 import GHC.Base
49 import GHC.Enum
50 import GHC.IO
51 import GHC.Real
52 import GHC.Show
53
54 -- | @'Time'@ is defined as a @'StgWord64'@ in @stg/Types.h@
55 --
56 -- @since 4.8.2.0
57 type RtsTime = Word64
58
59 -- | Should we produce a summary of the garbage collector statistics after the
60 -- program has exited?
61 --
62 -- @since 4.8.2.0
63 data GiveGCStats
64     = NoGCStats
65     | CollectGCStats
66     | OneLineGCStats
67     | SummaryGCStats
68     | VerboseGCStats
69     deriving (Show)
70
71 -- | @since 4.8.0.0
72 instance Enum GiveGCStats where
73     fromEnum NoGCStats      = #{const NO_GC_STATS}
74     fromEnum CollectGCStats = #{const COLLECT_GC_STATS}
75     fromEnum OneLineGCStats = #{const ONELINE_GC_STATS}
76     fromEnum SummaryGCStats = #{const SUMMARY_GC_STATS}
77     fromEnum VerboseGCStats = #{const VERBOSE_GC_STATS}
78
79     toEnum #{const NO_GC_STATS}      = NoGCStats
80     toEnum #{const COLLECT_GC_STATS} = CollectGCStats
81     toEnum #{const ONELINE_GC_STATS} = OneLineGCStats
82     toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats
83     toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats
84     toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e)
85
86 -- | Parameters of the garbage collector.
87 --
88 -- @since 4.8.0.0
89 data GCFlags = GCFlags
90     { statsFile             :: Maybe FilePath
91     , giveStats             :: GiveGCStats
92     , maxStkSize            :: Word32
93     , initialStkSize        :: Word32
94     , stkChunkSize          :: Word32
95     , stkChunkBufferSize    :: Word32
96     , maxHeapSize           :: Word32
97     , minAllocAreaSize      :: Word32
98     , largeAllocLim         :: Word32
99     , nurseryChunkSize      :: Word32
100     , minOldGenSize         :: Word32
101     , heapSizeSuggestion    :: Word32
102     , heapSizeSuggestionAuto :: Bool
103     , oldGenFactor          :: Double
104     , pcFreeHeap            :: Double
105     , generations           :: Word32
106     , squeezeUpdFrames      :: Bool
107     , compact               :: Bool -- ^ True <=> "compact all the time"
108     , compactThreshold      :: Double
109     , sweep                 :: Bool
110       -- ^ use "mostly mark-sweep" instead of copying for the oldest generation
111     , ringBell              :: Bool
112     , idleGCDelayTime       :: RtsTime
113     , doIdleGC              :: Bool
114     , heapBase              :: Word -- ^ address to ask the OS for memory
115     , allocLimitGrace       :: Word
116     , numa                  :: Bool
117     , numaMask              :: Word
118     } deriving (Show)
119
120 -- | Parameters concerning context switching
121 --
122 -- @since 4.8.0.0
123 data ConcFlags = ConcFlags
124     { ctxtSwitchTime  :: RtsTime
125     , ctxtSwitchTicks :: Int
126     } deriving (Show)
127
128 -- | Miscellaneous parameters
129 --
130 -- @since 4.8.0.0
131 data MiscFlags = MiscFlags
132     { tickInterval          :: RtsTime
133     , installSignalHandlers :: Bool
134     , installSEHHandlers    :: Bool
135     , machineReadable       :: Bool
136     , linkerMemBase         :: Word
137       -- ^ address to ask the OS for memory for the linker, 0 ==> off
138     } deriving (Show)
139
140 -- | Flags to control debugging output & extra checking in various
141 -- subsystems.
142 --
143 -- @since 4.8.0.0
144 data DebugFlags = DebugFlags
145     { scheduler   :: Bool -- ^ 's'
146     , interpreter :: Bool -- ^ 'i'
147     , weak        :: Bool -- ^ 'w'
148     , gccafs      :: Bool -- ^ 'G'
149     , gc          :: Bool -- ^ 'g'
150     , block_alloc :: Bool -- ^ 'b'
151     , sanity      :: Bool -- ^ 'S'
152     , stable      :: Bool -- ^ 't'
153     , prof        :: Bool -- ^ 'p'
154     , linker      :: Bool -- ^ 'l' the object linker
155     , apply       :: Bool -- ^ 'a'
156     , stm         :: Bool -- ^ 'm'
157     , squeeze     :: Bool -- ^ 'z' stack squeezing & lazy blackholing
158     , hpc         :: Bool -- ^ 'c' coverage
159     , sparks      :: Bool -- ^ 'r'
160     } deriving (Show)
161
162 -- | Should the RTS produce a cost-center summary?
163 --
164 -- @since 4.8.2.0
165 data DoCostCentres
166     = CostCentresNone
167     | CostCentresSummary
168     | CostCentresVerbose
169     | CostCentresAll
170     | CostCentresJSON
171     deriving (Show)
172
173 -- | @since 4.8.0.0
174 instance Enum DoCostCentres where
175     fromEnum CostCentresNone    = #{const COST_CENTRES_NONE}
176     fromEnum CostCentresSummary = #{const COST_CENTRES_SUMMARY}
177     fromEnum CostCentresVerbose = #{const COST_CENTRES_VERBOSE}
178     fromEnum CostCentresAll     = #{const COST_CENTRES_ALL}
179     fromEnum CostCentresJSON    = #{const COST_CENTRES_JSON}
180
181     toEnum #{const COST_CENTRES_NONE}    = CostCentresNone
182     toEnum #{const COST_CENTRES_SUMMARY} = CostCentresSummary
183     toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose
184     toEnum #{const COST_CENTRES_ALL}     = CostCentresAll
185     toEnum #{const COST_CENTRES_JSON}    = CostCentresJSON
186     toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e)
187
188 -- | Parameters pertaining to the cost-center profiler.
189 --
190 -- @since 4.8.0.0
191 data CCFlags = CCFlags
192     { doCostCentres :: DoCostCentres
193     , profilerTicks :: Int
194     , msecsPerTick  :: Int
195     } deriving (Show)
196
197 -- | What sort of heap profile are we collecting?
198 --
199 -- @since 4.8.2.0
200 data DoHeapProfile
201     = NoHeapProfiling
202     | HeapByCCS
203     | HeapByMod
204     | HeapByDescr
205     | HeapByType
206     | HeapByRetainer
207     | HeapByLDV
208     | HeapByClosureType
209     deriving (Show)
210
211 -- | @since 4.8.0.0
212 instance Enum DoHeapProfile where
213     fromEnum NoHeapProfiling   = #{const NO_HEAP_PROFILING}
214     fromEnum HeapByCCS         = #{const HEAP_BY_CCS}
215     fromEnum HeapByMod         = #{const HEAP_BY_MOD}
216     fromEnum HeapByDescr       = #{const HEAP_BY_DESCR}
217     fromEnum HeapByType        = #{const HEAP_BY_TYPE}
218     fromEnum HeapByRetainer    = #{const HEAP_BY_RETAINER}
219     fromEnum HeapByLDV         = #{const HEAP_BY_LDV}
220     fromEnum HeapByClosureType = #{const HEAP_BY_CLOSURE_TYPE}
221
222     toEnum #{const NO_HEAP_PROFILING}    = NoHeapProfiling
223     toEnum #{const HEAP_BY_CCS}          = HeapByCCS
224     toEnum #{const HEAP_BY_MOD}          = HeapByMod
225     toEnum #{const HEAP_BY_DESCR}        = HeapByDescr
226     toEnum #{const HEAP_BY_TYPE}         = HeapByType
227     toEnum #{const HEAP_BY_RETAINER}     = HeapByRetainer
228     toEnum #{const HEAP_BY_LDV}          = HeapByLDV
229     toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType
230     toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e)
231
232 -- | Parameters of the cost-center profiler
233 --
234 -- @since 4.8.0.0
235 data ProfFlags = ProfFlags
236     { doHeapProfile            :: DoHeapProfile
237     , heapProfileInterval      :: RtsTime -- ^ time between samples
238     , heapProfileIntervalTicks :: Word    -- ^ ticks between samples (derived)
239     , includeTSOs              :: Bool
240     , showCCSOnException       :: Bool
241     , maxRetainerSetSize       :: Word
242     , ccsLength                :: Word
243     , modSelector              :: Maybe String
244     , descrSelector            :: Maybe String
245     , typeSelector             :: Maybe String
246     , ccSelector               :: Maybe String
247     , ccsSelector              :: Maybe String
248     , retainerSelector         :: Maybe String
249     , bioSelector              :: Maybe String
250     } deriving (Show)
251
252 -- | Is event tracing enabled?
253 --
254 -- @since 4.8.2.0
255 data DoTrace
256     = TraceNone      -- ^ no tracing
257     | TraceEventLog  -- ^ send tracing events to the event log
258     | TraceStderr    -- ^ send tracing events to @stderr@
259     deriving (Show)
260
261 -- | @since 4.8.0.0
262 instance Enum DoTrace where
263     fromEnum TraceNone     = #{const TRACE_NONE}
264     fromEnum TraceEventLog = #{const TRACE_EVENTLOG}
265     fromEnum TraceStderr   = #{const TRACE_STDERR}
266
267     toEnum #{const TRACE_NONE}     = TraceNone
268     toEnum #{const TRACE_EVENTLOG} = TraceEventLog
269     toEnum #{const TRACE_STDERR}   = TraceStderr
270     toEnum e = errorWithoutStackTrace ("invalid enum for DoTrace: " ++ show e)
271
272 -- | Parameters pertaining to event tracing
273 --
274 -- @since 4.8.0.0
275 data TraceFlags = TraceFlags
276     { tracing        :: DoTrace
277     , timestamp      :: Bool -- ^ show timestamp in stderr output
278     , traceScheduler :: Bool -- ^ trace scheduler events
279     , traceGc        :: Bool -- ^ trace GC events
280     , sparksSampled  :: Bool -- ^ trace spark events by a sampled method
281     , sparksFull     :: Bool -- ^ trace spark events 100% accurately
282     , user           :: Bool -- ^ trace user events (emitted from Haskell code)
283     } deriving (Show)
284
285 -- | Parameters pertaining to ticky-ticky profiler
286 --
287 -- @since 4.8.0.0
288 data TickyFlags = TickyFlags
289     { showTickyStats :: Bool
290     , tickyFile      :: Maybe FilePath
291     } deriving (Show)
292
293 -- | Parameters pertaining to parallelism
294 --
295 -- @since 4.8.0.0
296 data ParFlags = ParFlags
297     { nCapabilities :: Word32
298     , migrate :: Bool
299     , maxLocalSparks :: Word32
300     , parGcEnabled :: Bool
301     , parGcGen :: Word32
302     , parGcLoadBalancingEnabled :: Bool
303     , parGcLoadBalancingGen :: Word32
304     , parGcNoSyncWithIdle :: Word32
305     , parGcThreads :: Word32
306     , setAffinity :: Bool
307     }
308     deriving (Show)
309
310 -- | Parameters of the runtime system
311 --
312 -- @since 4.8.0.0
313 data RTSFlags = RTSFlags
314     { gcFlags         :: GCFlags
315     , concurrentFlags :: ConcFlags
316     , miscFlags       :: MiscFlags
317     , debugFlags      :: DebugFlags
318     , costCentreFlags :: CCFlags
319     , profilingFlags  :: ProfFlags
320     , traceFlags      :: TraceFlags
321     , tickyFlags      :: TickyFlags
322     , parFlags        :: ParFlags
323     } deriving (Show)
324
325 foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr RTSFlags
326
327 getRTSFlags :: IO RTSFlags
328 getRTSFlags = do
329   RTSFlags <$> getGCFlags
330            <*> getConcFlags
331            <*> getMiscFlags
332            <*> getDebugFlags
333            <*> getCCFlags
334            <*> getProfFlags
335            <*> getTraceFlags
336            <*> getTickyFlags
337            <*> getParFlags
338
339 peekFilePath :: Ptr () -> IO (Maybe FilePath)
340 peekFilePath ptr
341   | ptr == nullPtr = return Nothing
342   | otherwise      = return (Just "<filepath>")
343
344 -- | Read a NUL terminated string. Return Nothing in case of a NULL pointer.
345 peekCStringOpt :: Ptr CChar -> IO (Maybe String)
346 peekCStringOpt ptr
347   | ptr == nullPtr = return Nothing
348   | otherwise      = Just <$> peekCString ptr
349
350 getGCFlags :: IO GCFlags
351 getGCFlags = do
352   let ptr = (#ptr RTS_FLAGS, GcFlags) rtsFlagsPtr
353   GCFlags <$> (peekFilePath =<< #{peek GC_FLAGS, statsFile} ptr)
354           <*> (toEnum . fromIntegral <$>
355                 (#{peek GC_FLAGS, giveStats} ptr :: IO Word32))
356           <*> #{peek GC_FLAGS, maxStkSize} ptr
357           <*> #{peek GC_FLAGS, initialStkSize} ptr
358           <*> #{peek GC_FLAGS, stkChunkSize} ptr
359           <*> #{peek GC_FLAGS, stkChunkBufferSize} ptr
360           <*> #{peek GC_FLAGS, maxHeapSize} ptr
361           <*> #{peek GC_FLAGS, minAllocAreaSize} ptr
362           <*> #{peek GC_FLAGS, largeAllocLim} ptr
363           <*> #{peek GC_FLAGS, nurseryChunkSize} ptr
364           <*> #{peek GC_FLAGS, minOldGenSize} ptr
365           <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr
366           <*> #{peek GC_FLAGS, heapSizeSuggestionAuto} ptr
367           <*> #{peek GC_FLAGS, oldGenFactor} ptr
368           <*> #{peek GC_FLAGS, pcFreeHeap} ptr
369           <*> #{peek GC_FLAGS, generations} ptr
370           <*> #{peek GC_FLAGS, squeezeUpdFrames} ptr
371           <*> #{peek GC_FLAGS, compact} ptr
372           <*> #{peek GC_FLAGS, compactThreshold} ptr
373           <*> #{peek GC_FLAGS, sweep} ptr
374           <*> #{peek GC_FLAGS, ringBell} ptr
375           <*> #{peek GC_FLAGS, idleGCDelayTime} ptr
376           <*> #{peek GC_FLAGS, doIdleGC} ptr
377           <*> #{peek GC_FLAGS, heapBase} ptr
378           <*> #{peek GC_FLAGS, allocLimitGrace} ptr
379           <*> #{peek GC_FLAGS, numa} ptr
380           <*> #{peek GC_FLAGS, numaMask} ptr
381
382 getParFlags :: IO ParFlags
383 getParFlags = do
384   let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr
385   ParFlags
386     <$> #{peek PAR_FLAGS, nCapabilities} ptr
387     <*> #{peek PAR_FLAGS, migrate} ptr
388     <*> #{peek PAR_FLAGS, maxLocalSparks} ptr
389     <*> #{peek PAR_FLAGS, parGcEnabled} ptr
390     <*> #{peek PAR_FLAGS, parGcGen} ptr
391     <*> #{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr
392     <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr
393     <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr
394     <*> #{peek PAR_FLAGS, parGcThreads} ptr
395     <*> #{peek PAR_FLAGS, setAffinity} ptr
396
397 getConcFlags :: IO ConcFlags
398 getConcFlags = do
399   let ptr = (#ptr RTS_FLAGS, ConcFlags) rtsFlagsPtr
400   ConcFlags <$> #{peek CONCURRENT_FLAGS, ctxtSwitchTime} ptr
401             <*> #{peek CONCURRENT_FLAGS, ctxtSwitchTicks} ptr
402
403 getMiscFlags :: IO MiscFlags
404 getMiscFlags = do
405   let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr
406   MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
407             <*> #{peek MISC_FLAGS, install_signal_handlers} ptr
408             <*> #{peek MISC_FLAGS, install_seh_handlers} ptr
409             <*> #{peek MISC_FLAGS, machineReadable} ptr
410             <*> #{peek MISC_FLAGS, linkerMemBase} ptr
411
412 getDebugFlags :: IO DebugFlags
413 getDebugFlags = do
414   let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr
415   DebugFlags <$> #{peek DEBUG_FLAGS, scheduler} ptr
416              <*> #{peek DEBUG_FLAGS, interpreter} ptr
417              <*> #{peek DEBUG_FLAGS, weak} ptr
418              <*> #{peek DEBUG_FLAGS, gccafs} ptr
419              <*> #{peek DEBUG_FLAGS, gc} ptr
420              <*> #{peek DEBUG_FLAGS, block_alloc} ptr
421              <*> #{peek DEBUG_FLAGS, sanity} ptr
422              <*> #{peek DEBUG_FLAGS, stable} ptr
423              <*> #{peek DEBUG_FLAGS, prof} ptr
424              <*> #{peek DEBUG_FLAGS, linker} ptr
425              <*> #{peek DEBUG_FLAGS, apply} ptr
426              <*> #{peek DEBUG_FLAGS, stm} ptr
427              <*> #{peek DEBUG_FLAGS, squeeze} ptr
428              <*> #{peek DEBUG_FLAGS, hpc} ptr
429              <*> #{peek DEBUG_FLAGS, sparks} ptr
430
431 getCCFlags :: IO CCFlags
432 getCCFlags = do
433   let ptr = (#ptr RTS_FLAGS, GcFlags) rtsFlagsPtr
434   CCFlags <$> (toEnum . fromIntegral
435                 <$> (#{peek COST_CENTRE_FLAGS, doCostCentres} ptr :: IO Word32))
436           <*> #{peek COST_CENTRE_FLAGS, profilerTicks} ptr
437           <*> #{peek COST_CENTRE_FLAGS, msecsPerTick} ptr
438
439 getProfFlags :: IO ProfFlags
440 getProfFlags = do
441   let ptr = (#ptr RTS_FLAGS, ProfFlags) rtsFlagsPtr
442   ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr)
443             <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr
444             <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr
445             <*> #{peek PROFILING_FLAGS, includeTSOs} ptr
446             <*> #{peek PROFILING_FLAGS, showCCSOnException} ptr
447             <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr
448             <*> #{peek PROFILING_FLAGS, ccsLength} ptr
449             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr)
450             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, descrSelector} ptr)
451             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, typeSelector} ptr)
452             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccSelector} ptr)
453             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccsSelector} ptr)
454             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, retainerSelector} ptr)
455             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, bioSelector} ptr)
456
457 getTraceFlags :: IO TraceFlags
458 getTraceFlags = do
459   let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr
460   TraceFlags <$> (toEnum . fromIntegral
461                    <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt))
462              <*> #{peek TRACE_FLAGS, timestamp} ptr
463              <*> #{peek TRACE_FLAGS, scheduler} ptr
464              <*> #{peek TRACE_FLAGS, gc} ptr
465              <*> #{peek TRACE_FLAGS, sparks_sampled} ptr
466              <*> #{peek TRACE_FLAGS, sparks_full} ptr
467              <*> #{peek TRACE_FLAGS, user} ptr
468
469 getTickyFlags :: IO TickyFlags
470 getTickyFlags = do
471   let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr
472   TickyFlags <$> #{peek TICKY_FLAGS, showTickyStats} ptr
473              <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr)