ghc-eventlog-loopback-0.1.0.0: src/GHC/RTS/Events/Loopback.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module GHC.RTS.Events.Loopback
  ( start
  , stop
  , readEventLogChunk
  ) where

import Foreign.StablePtr
import Foreign.Ptr
import Foreign.ForeignPtr
import GHC.Conc
import Foreign.Storable
import Foreign.Marshal.Alloc
import Data.ByteString.Internal
import Data.Word
import Control.Concurrent

foreign import ccall "startLoopbackWriter" startLoopbackWriter :: IO ()
foreign import ccall "stopLoopbackWriter" stopLoopbackWriter :: IO ()
foreign import ccall "registerWakeup" registerWakeup :: Int -> StablePtr PrimMVar -> IO ()
foreign import ccall "popChunk" popChunk :: IO (Ptr Int)
foreign import ccall "freeChunk" freeChunk :: Ptr Int-> IO ()

-- | Replace the built-in eventlog backend with the loopback backend.
start :: IO ()
start = startLoopbackWriter

-- | Read an eventlog chunk. If no chunks are available then this function will block.
-- The 'ByteString' chunks can then be fed to the parser from @ghc-events@.
readEventLogChunk :: IO ByteString
readEventLogChunk = do
  entryPtr <- popChunk
  if nullPtr == entryPtr
    then do
      -- if we there are no chunks,
      -- then register a wakeup call for when we get one.
      mvar <- newEmptyMVar @()
      sp <- newStablePtrPrimMVar mvar
      (cap, _) <- threadCapability =<< myThreadId
      registerWakeup cap sp
      takeMVar mvar
      -- Try again, since we've got some chunks now
      readEventLogChunk
    else do
      size <- peek @Int entryPtr
      ptr <- peek @(Ptr Word8) (entryPtr `plusPtr` (sizeOf (undefined :: Int)))
      fptr <- newForeignPtr finalizerFree ptr
      freeChunk entryPtr
      pure $ BS fptr size

-- | Stop the loopback eventlog backend.
stop :: IO ()
stop = stopLoopbackWriter