summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2022-04-22 23:33:12 +0200
committerTom Smeding <tom@tomsmeding.com>2022-04-22 23:38:30 +0200
commit6ca1e41da1d702467dbfb0d6bf7b463884eedc31 (patch)
tree0a68c1341abdd370b7086985fbc4fc0c0132a2c8 /src
parent3654951ca31b225c84c1b1fa8eafe34b701c91e6 (diff)
0.2.0: C hook delegate and enable/disable logging
Diffstat (limited to 'src')
-rw-r--r--src/GHC/GC_Hook.hs96
1 files changed, 73 insertions, 23 deletions
diff --git a/src/GHC/GC_Hook.hs b/src/GHC/GC_Hook.hs
index 35fbbc5..b3e1947 100644
--- a/src/GHC/GC_Hook.hs
+++ b/src/GHC/GC_Hook.hs
@@ -3,29 +3,39 @@
{-# LANGUAGE TypeApplications #-}
module GHC.GC_Hook (
setGCHook,
+ enableGClogging,
getGCLog,
+ gcSetHookDelegate,
Details(..),
) where
+import Control.Exception (throwIO)
import Control.Monad ((>=>))
import Data.Word (Word32, Word64)
-import Foreign.C.Types (CChar, CSize(..))
+import Foreign.C.Types (CBool(..), CChar, CSize(..))
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (peek)
import qualified System.Clock as Clock
-foreign import ccall "set_gchook" c_set_gchook
- :: IO ()
foreign import ccall "copy_log_to_buffer" c_copy_log_to_buffer
:: CSize -> Ptr CChar -> Ptr CSize -> Ptr CSize -> IO ()
+foreign import ccall "set_gchook" c_set_gchook
+ :: IO CBool
+foreign import ccall "gchook_enable_logging" c_gchook_enable_logging
+ :: CBool -> IO ()
+foreign import ccall "gchook_set_c_delegate" c_gchook_set_c_delegate
+ :: Ptr () -> IO CBool
-- | GC details as given to the GC hook installed by 'setGCHook'. The only
--- field that is not contained in `GCDetails_` provided by the GHC RTS is
+-- field that is not contained in @GCDetails_@ provided by the GHC RTS is
-- 'detTimestamp', which is the time at which the GC was finished. The GC start
-- time can probably be computed by subtracting 'detElapsedNs' from this.
+--
+-- The documentation of the fields (other than @detTimestamp@) is copied from
+-- GHC @rts\/include\/RtsAPI.h@.
data Details = Details
- { -- | The timestamp at which the GC was finished (i.e. `gcDoneHook` was
+ { -- | The timestamp at which the GC was finished (i.e. @gcDoneHook@ was
-- called). Note: this is recorded using the 'Clock.Monotonic' clock.
detTimestamp :: Clock.TimeSpec
@@ -35,7 +45,7 @@ data Details = Details
detThreads :: Word32
, -- | Number of bytes allocated since the previous GC
detAllocatedBytes :: Word64
- , -- | Total amount of live data in the heap (incliudes large + compact data).
+ , -- | Total amount of live data in the heap (includes large + compact data).
-- Updated after every GC. Data in uncollected generations (in minor GCs)
-- are considered live.
detLiveBytes :: Word64
@@ -53,35 +63,28 @@ data Details = Details
detParMaxCopiedBytes :: Word64
, -- | In parallel GC, the amount of balanced data copied by all threads
detParBalancedCopiedBytes :: Word64
- , -- | The time elapsed during synchronisation before GC
- -- NOTE: nanoseconds!
+ , -- | (nanoseconds) The time elapsed during synchronisation before GC
detSyncElapsedNs :: Word64
- , -- | The CPU time used during GC itself
- -- NOTE: nanoseconds!
+ , -- | (nanoseconds) The CPU time used during GC itself
detCpuNs :: Word64
- , -- | The time elapsed during GC itself
- -- NOTE: nanoseconds!
+ , -- | (nanoseconds) The time elapsed during GC itself
detElapsedNs :: Word64
- , -- | Concurrent garbage collector.
+ , -- | (nanoseconds) Concurrent garbage collector.
-- The CPU time used during the post-mark pause phase of the concurrent
-- nonmoving GC.
- -- NOTE: nanoseconds!
detNonmovingGcSyncCpuNs :: Word64
- , -- | Concurrent garbage collector.
+ , -- | (nanoseconds) Concurrent garbage collector.
-- The time elapsed during the post-mark pause phase of the concurrent
-- nonmoving GC.
- -- NOTE: nanoseconds!
detNonmovingGcSyncElapsedNs :: Word64
- , -- | Concurrent garbage collector.
+ , -- | (nanoseconds) Concurrent garbage collector.
-- The CPU time used during the post-mark pause phase of the concurrent
-- nonmoving GC.
- -- NOTE: nanoseconds!
detNonmovingGcCpuNs :: Word64
- , -- | Concurrent garbage collector.
+ , -- | (nanoseconds) Concurrent garbage collector.
-- The time elapsed during the post-mark pause phase of the concurrent
-- nonmoving GC.
- -- NOTE: nanoseconds!
detNonmovingGcElapsedNs :: Word64
}
deriving (Show)
@@ -89,13 +92,60 @@ data Details = Details
zeroDetails :: Details
zeroDetails = Details (Clock.fromNanoSecs 0) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
--- | Initialise the GC hook.
+-- | Initialise the GC hook. Note: to use 'getGCLog' you first need to also
+-- call @'enableGClogging' True@.
setGCHook :: IO ()
-setGCHook = do
- c_set_gchook
+setGCHook =
+ c_set_gchook >>= \case
+ CBool 0 -> throwIO (userError "Failure setting GC hook")
+ CBool _ -> return ()
+
+-- | Enable or disable GC logging. If the argument is true, logging is enabled;
+-- if the argument is false, any pending logs are cleared and logging is
+-- disabled from now on.
+enableGClogging :: Bool -> IO ()
+enableGClogging yes = c_gchook_enable_logging (CBool (if yes then 1 else 0))
+
+-- | Set a C function to be called after every GC. Use this in the following manner:
+--
+-- * Create a file @cbits/something.c@ in your project (the actual file name
+-- doesn't matter), and add @c-sources: cbits/something.c@ to the stanza of
+-- the correct component in your .cabal file.
+-- * Put the following in it: (The function names are unimportant.)
+--
+-- > #include "Rts.h"
+-- >
+-- > // the static is unnecessary, but neat
+-- > static void my_delegate_function(const struct GCDetails_ *d) {
+-- > // put your code here
+-- > }
+-- >
+-- > void* get_my_delegate_ptr(void) {
+-- > return my_delegate_function;
+-- > }
+--
+-- * Use the following in Haskell:
+--
+-- @
+-- {-# LANGUAGE ForeignFunctionInterface #-}
+-- import Foreign.Ptr (Ptr)
+-- foreign import ccall "get_my_delegate_ptr" c_get_my_delegate_ptr :: IO (Ptr ())
+-- -- ...
+-- do funptr <- c_get_my_delegate_ptr
+-- 'gcSetHookDelegate' funptr
+-- @
+gcSetHookDelegate :: Ptr () -> IO ()
+gcSetHookDelegate funptr =
+ c_gchook_set_c_delegate funptr >>= \case
+ CBool 0 -> throwIO (userError "Failure setting hook delegate, already set?")
+ CBool _ -> return ()
-- | Get the log of 'Details' structures up until now; also clears the log. You
-- will never get the same structure twice.
+--
+-- Note: This is not entirely atomic. If you call this function concurrently,
+-- it is possible that alternatingly, some events go to one 'getGCLog' call and
+-- other events go to the other call.
getGCLog :: IO [Details]
getGCLog =
getLogBatch >>= \case