summaryrefslogtreecommitdiff
path: root/test/Main.hs
blob: aad5ebb7210506a2382517e03555a872ea8e063b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Control.Monad (forM_, when)
import qualified System.Clock as Clock
import Foreign.Ptr (Ptr)

import GHC.GC_Hook


foreign import ccall "get_my_delegate_ptr" c_get_my_delegate_ptr :: IO (Ptr ())


{-# NOINLINE invokeGCsometimes #-}
invokeGCsometimes :: IO ()
invokeGCsometimes =
  forM_ [1..10] $ \i -> do
    let l = [i..10000]
    print (sum l + product l + length l)

main :: IO ()
main = do
  setGCHook

  invokeGCsometimes

  enabletm <- Clock.getTime Clock.Monotonic
  enableGClogging True

  invokeGCsometimes

  gclog <- getGCLog
  when (length gclog == 0) $
    fail "GC log was unexpectedly empty"
  when (any ((< enabletm) . detTimestamp) gclog) $ do
    _ <- fail "Logging was already on before enableGClogging"
    print enabletm
    putStrLn "--"
    mapM_ print (map detTimestamp gclog)

  c_get_my_delegate_ptr >>= gcSetHookDelegate
  invokeGCsometimes