{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeApplications #-}
module GHC.GC_Hook (
  setGCHook,
  getGCLog,
) where

import Control.Monad ((>=>))
import Data.Word (Word32, Word64)
import Foreign.C.Types (CChar, CSize(..))
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (peek)

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 ()

data Details = Details
  { -- | The generation number of this GC
    detGen :: Word32
  , -- | Number of threads used in this GC
    detThreads :: Word32
  , -- | Number of bytes allocated since the previous GC
    detAllocatedBytes :: Word64
  , -- | Total amount of live data in the heap (incliudes large + compact data).
    -- Updated after every GC. Data in uncollected generations (in minor GCs)
    -- are considered live.
    detLiveBytes :: Word64
  , -- | Total amount of live data in large objects
    detLargeObjectsBytes :: Word64
  , -- | Total amount of live data in compact regions
    detCompactBytes :: Word64
  , -- | Total amount of slop (wasted memory)
    detSlopBytes :: Word64
  , -- | Total amount of memory in use by the RTS
    detMemInUseBytes :: Word64
  , -- | Total amount of data copied during this GC
    detCopiedBytes :: Word64
  , -- | In parallel GC, the max amount of data copied by any one thread
    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!
    detSyncElapsedNs :: Word64
  , -- | The CPU time used during GC itself
    -- NOTE: nanoseconds!
    detCpuNs :: Word64
  , -- | The time elapsed during GC itself
    -- NOTE: nanoseconds!
    detElapsedNs :: Word64

  , -- | 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.
    -- The time elapsed during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    -- NOTE: nanoseconds!
    detNonmovingGcSyncElapsedNs :: Word64
  , -- | 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.
    -- The time elapsed during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    -- NOTE: nanoseconds!
    detNonmovingGcElapsedNs :: Word64
  }
  deriving (Show)

zeroDetails :: Details
zeroDetails = Details 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

setGCHook :: IO ()
setGCHook = do
  c_set_gchook

getGCLog :: IO [Details]
getGCLog =
  let bufferCapacity = 2048
  in allocaBytes bufferCapacity $ \pbuffer ->
     alloca $ \punitsize ->
     alloca $ \pnumstored -> do
       c_copy_log_to_buffer (fromIntegral @Int @CSize bufferCapacity) pbuffer punitsize pnumstored
       unitsize <- fromIntegral @CSize @Int <$> peek punitsize
       numstored <- fromIntegral @CSize @Int <$> peek pnumstored
       sequence [peekDetails unitsize (pbuffer `plusPtr` (i * unitsize))
                | i <- [0 .. numstored - 1]]

peekDetails :: Int -> Ptr a -> IO Details
peekDetails unitsize startptr =
  let getField :: Int -> (Int, Ptr a -> Details -> IO Details)
               -> Details -> IO Details
      getField offset (_, fun) = fun (startptr `plusPtr` offset)
  in if last offsets == unitsize
       then foldr (>=>) return (zipWith getField offsets fields) zeroDetails
       else error "hook.c not compatible with GC_Hook.hs, ShadowDetails mismatch"
  where
    fields :: [(Int, Ptr a -> Details -> IO Details)]
    fields =
      [(4, peekModify $ \d x -> d { detGen = x })
      ,(4, peekModify $ \d x -> d { detThreads = x })
      ,(8, peekModify $ \d x -> d { detAllocatedBytes = x })
      ,(8, peekModify $ \d x -> d { detLiveBytes = x })
      ,(8, peekModify $ \d x -> d { detLargeObjectsBytes = x })
      ,(8, peekModify $ \d x -> d { detCompactBytes = x })
      ,(8, peekModify $ \d x -> d { detSlopBytes = x })
      ,(8, peekModify $ \d x -> d { detMemInUseBytes = x })
      ,(8, peekModify $ \d x -> d { detCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detParMaxCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detParBalancedCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detSyncElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detCpuNs = x })
      ,(8, peekModify $ \d x -> d { detElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcSyncCpuNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcSyncElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcCpuNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcElapsedNs = x })
      ]
      where peekModify g p d = peek (castPtr p) >>= \x -> return (g d x)

    offsets :: [Int]
    offsets = scanl (+) 0 (map fst fields)