{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Crypto.AllocLog where

import Control.Tracer
import Data.Typeable
import Foreign.Concurrent
import Foreign.Ptr

import Cardano.Crypto.Libsodium (withMLockedForeignPtr)
import Cardano.Crypto.Libsodium.Memory (MLockedAllocator (..))
import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..))

-- | Allocation log event. These are emitted automatically whenever mlocked
-- memory is allocated through the 'mlockedAllocForeignPtr' primitive, or
-- released through an associated finalizer (either explicitly or due to GC).
-- Additional events that are not actual allocations/deallocations, but may
-- provide useful debugging context, can be inserted as 'MarkerEv'.
data AllocEvent
  = AllocEv !WordPtr
  | FreeEv !WordPtr
  | MarkerEv !String
  deriving (AllocEvent -> AllocEvent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllocEvent -> AllocEvent -> Bool
$c/= :: AllocEvent -> AllocEvent -> Bool
== :: AllocEvent -> AllocEvent -> Bool
$c== :: AllocEvent -> AllocEvent -> Bool
Eq, Int -> AllocEvent -> ShowS
[AllocEvent] -> ShowS
AllocEvent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllocEvent] -> ShowS
$cshowList :: [AllocEvent] -> ShowS
show :: AllocEvent -> String
$cshow :: AllocEvent -> String
showsPrec :: Int -> AllocEvent -> ShowS
$cshowsPrec :: Int -> AllocEvent -> ShowS
Show, Typeable)

mkLoggingAllocator ::
  Tracer IO AllocEvent -> MLockedAllocator IO -> MLockedAllocator IO
mkLoggingAllocator :: Tracer IO AllocEvent -> MLockedAllocator IO -> MLockedAllocator IO
mkLoggingAllocator Tracer IO AllocEvent
tracer MLockedAllocator IO
ioAllocator =
  MLockedAllocator
    { mlAllocate :: forall a. CSize -> IO (MLockedForeignPtr a)
mlAllocate =
        \CSize
size -> do
          sfptr :: MLockedForeignPtr a
sfptr@(SFP ForeignPtr a
fptr) <- forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator IO
ioAllocator CSize
size
          WordPtr
addr <- forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr MLockedForeignPtr a
sfptr (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ptr a -> WordPtr
ptrToWordPtr)
          forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO AllocEvent
tracer (WordPtr -> AllocEvent
AllocEv WordPtr
addr)
          forall a. ForeignPtr a -> IO () -> IO ()
addForeignPtrFinalizer ForeignPtr a
fptr (forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO AllocEvent
tracer (WordPtr -> AllocEvent
FreeEv WordPtr
addr))
          forall (m :: * -> *) a. Monad m => a -> m a
return MLockedForeignPtr a
sfptr
    }