Flags.hsc: Peek a CBool (Word8), not a Bool (Int32)
authorJames Clarke <jrtc27@jrtc27.com>
Mon, 16 Oct 2017 21:37:55 +0000 (17:37 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 16 Oct 2017 21:37:56 +0000 (17:37 -0400)
Reviewers: austin, hvr, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

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

libraries/base/GHC/RTS/Flags.hsc

index 62b79ed..7d5b705 100644 (file)
@@ -364,20 +364,27 @@ getGCFlags = do
           <*> #{peek GC_FLAGS, nurseryChunkSize} ptr
           <*> #{peek GC_FLAGS, minOldGenSize} ptr
           <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr
           <*> #{peek GC_FLAGS, nurseryChunkSize} ptr
           <*> #{peek GC_FLAGS, minOldGenSize} ptr
           <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr
-          <*> #{peek GC_FLAGS, heapSizeSuggestionAuto} ptr
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, heapSizeSuggestionAuto} ptr :: IO CBool))
           <*> #{peek GC_FLAGS, oldGenFactor} ptr
           <*> #{peek GC_FLAGS, pcFreeHeap} ptr
           <*> #{peek GC_FLAGS, generations} ptr
           <*> #{peek GC_FLAGS, oldGenFactor} ptr
           <*> #{peek GC_FLAGS, pcFreeHeap} ptr
           <*> #{peek GC_FLAGS, generations} ptr
-          <*> #{peek GC_FLAGS, squeezeUpdFrames} ptr
-          <*> #{peek GC_FLAGS, compact} ptr
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, squeezeUpdFrames} ptr :: IO CBool))
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, compact} ptr :: IO CBool))
           <*> #{peek GC_FLAGS, compactThreshold} ptr
           <*> #{peek GC_FLAGS, compactThreshold} ptr
-          <*> #{peek GC_FLAGS, sweep} ptr
-          <*> #{peek GC_FLAGS, ringBell} ptr
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, sweep} ptr :: IO CBool))
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, ringBell} ptr :: IO CBool))
           <*> #{peek GC_FLAGS, idleGCDelayTime} ptr
           <*> #{peek GC_FLAGS, idleGCDelayTime} ptr
-          <*> #{peek GC_FLAGS, doIdleGC} ptr
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, doIdleGC} ptr :: IO CBool))
           <*> #{peek GC_FLAGS, heapBase} ptr
           <*> #{peek GC_FLAGS, allocLimitGrace} ptr
           <*> #{peek GC_FLAGS, heapBase} ptr
           <*> #{peek GC_FLAGS, allocLimitGrace} ptr
-          <*> #{peek GC_FLAGS, numa} ptr
+          <*> (toBool <$>
+                (#{peek GC_FLAGS, numa} ptr :: IO CBool))
           <*> #{peek GC_FLAGS, numaMask} ptr
 
 getParFlags :: IO ParFlags
           <*> #{peek GC_FLAGS, numaMask} ptr
 
 getParFlags :: IO ParFlags
@@ -385,15 +392,19 @@ getParFlags = do
   let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr
   ParFlags
     <$> #{peek PAR_FLAGS, nCapabilities} ptr
   let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr
   ParFlags
     <$> #{peek PAR_FLAGS, nCapabilities} ptr
-    <*> #{peek PAR_FLAGS, migrate} ptr
+    <*> (toBool <$>
+          (#{peek PAR_FLAGS, migrate} ptr :: IO CBool))
     <*> #{peek PAR_FLAGS, maxLocalSparks} ptr
     <*> #{peek PAR_FLAGS, maxLocalSparks} ptr
-    <*> #{peek PAR_FLAGS, parGcEnabled} ptr
+    <*> (toBool <$>
+          (#{peek PAR_FLAGS, parGcEnabled} ptr :: IO CBool))
     <*> #{peek PAR_FLAGS, parGcGen} ptr
     <*> #{peek PAR_FLAGS, parGcGen} ptr
-    <*> #{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr
+    <*> (toBool <$>
+          (#{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr :: IO CBool))
     <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr
     <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr
     <*> #{peek PAR_FLAGS, parGcThreads} ptr
     <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr
     <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr
     <*> #{peek PAR_FLAGS, parGcThreads} ptr
-    <*> #{peek PAR_FLAGS, setAffinity} ptr
+    <*> (toBool <$>
+          (#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool))
 
 getConcFlags :: IO ConcFlags
 getConcFlags = do
 
 getConcFlags :: IO ConcFlags
 getConcFlags = do
@@ -405,30 +416,49 @@ getMiscFlags :: IO MiscFlags
 getMiscFlags = do
   let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr
   MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
 getMiscFlags = do
   let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr
   MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr
-            <*> #{peek MISC_FLAGS, install_signal_handlers} ptr
-            <*> #{peek MISC_FLAGS, install_seh_handlers} ptr
-            <*> #{peek MISC_FLAGS, generate_dump_file} ptr
-            <*> #{peek MISC_FLAGS, machineReadable} ptr
+            <*> (toBool <$>
+                  (#{peek MISC_FLAGS, install_signal_handlers} ptr :: IO CBool))
+            <*> (toBool <$>
+                  (#{peek MISC_FLAGS, install_seh_handlers} ptr :: IO CBool))
+            <*> (toBool <$>
+                  (#{peek MISC_FLAGS, generate_dump_file} ptr :: IO CBool))
+            <*> (toBool <$>
+                  (#{peek MISC_FLAGS, machineReadable} ptr :: IO CBool))
             <*> #{peek MISC_FLAGS, linkerMemBase} ptr
 
 getDebugFlags :: IO DebugFlags
 getDebugFlags = do
   let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr
             <*> #{peek MISC_FLAGS, linkerMemBase} ptr
 
 getDebugFlags :: IO DebugFlags
 getDebugFlags = do
   let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr
-  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
+  DebugFlags <$> (toBool <$>
+                   (#{peek DEBUG_FLAGS, scheduler} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, interpreter} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, weak} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, gccafs} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, gc} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, block_alloc} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, sanity} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, stable} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, prof} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, linker} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, apply} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, stm} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, squeeze} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool))
 
 getCCFlags :: IO CCFlags
 getCCFlags = do
 
 getCCFlags :: IO CCFlags
 getCCFlags = do
@@ -444,8 +474,10 @@ getProfFlags = do
   ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr)
             <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr
             <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr
   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
+            <*> (toBool <$>
+                  (#{peek PROFILING_FLAGS, includeTSOs} ptr :: IO CBool))
+            <*> (toBool <$>
+                  (#{peek PROFILING_FLAGS, showCCSOnException} ptr :: IO CBool))
             <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr
             <*> #{peek PROFILING_FLAGS, ccsLength} ptr
             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr)
             <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr
             <*> #{peek PROFILING_FLAGS, ccsLength} ptr
             <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr)
@@ -461,15 +493,22 @@ getTraceFlags = do
   let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr
   TraceFlags <$> (toEnum . fromIntegral
                    <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt))
   let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr
   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
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, timestamp} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, scheduler} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, gc} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, sparks_sampled} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool))
+             <*> (toBool <$>
+                   (#{peek TRACE_FLAGS, user} ptr :: IO CBool))
 
 getTickyFlags :: IO TickyFlags
 getTickyFlags = do
   let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr
 
 getTickyFlags :: IO TickyFlags
 getTickyFlags = do
   let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr
-  TickyFlags <$> #{peek TICKY_FLAGS, showTickyStats} ptr
+  TickyFlags <$> (toBool <$>
+                   (#{peek TICKY_FLAGS, showTickyStats} ptr :: IO CBool))
              <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr)
              <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr)