{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-|
Arbitary binary object logging available for GHC 8.8 or later. Unlike the other
tracing functions 'traceBinaryEvent' takes an arbitrary 'B.ByteString' object as
opposed to a UTF-8 encoded string.
-}
module Debug.Trace.Binary
  ( -- * Binary eventlog tracing
     traceBinaryEvent
  , traceBinaryEventIO
  ) where
import Control.Monad (when)
import GHC.Exts (Ptr(..), Int(..), traceBinaryEvent#)
import GHC.IO (IO(..))
import qualified System.IO.Unsafe as Unsafe

import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU

import Debug.Trace.Flags (userTracingEnabled)

-- | The 'traceBinaryEvent' function behaves like
-- 'Debug.Trace.ByteString.traceEvent' but with the difference that the message
-- is a binary object rather than a UTF-8 encoded string.
--
-- It is suitable for use in pure code. In an IO context use
-- 'traceBinaryEventIO' instead.
--
-- Note that when using GHC's SMP runtime, it is possible (but rare) to get
-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk
-- that uses 'traceBinaryEvent'.
--
-- Also note that this function doesn't evaluate the 'B.ByteString' if user
-- tracing in evnetlog is disabled.
--
-- The input should be shorter than \(2^{16}\) bytes. Otherwise the RTS
-- generates a broken eventlog.
traceBinaryEvent :: B.ByteString -> a -> a
traceBinaryEvent :: ByteString -> a -> a
traceBinaryEvent ByteString
bytes a
a
  | Bool
userTracingEnabled = ByteString -> a -> a
forall a. ByteString -> a -> a
traceBinaryEvent' ByteString
bytes a
a
  | Bool
otherwise = a
a

traceBinaryEvent' :: B.ByteString -> a -> a
traceBinaryEvent' :: ByteString -> a -> a
traceBinaryEvent' ByteString
bytes a
a = IO a -> a
forall a. IO a -> a
Unsafe.unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> IO ()
traceBinaryEventIO' ByteString
bytes
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# NOINLINE traceBinaryEvent' #-}

-- | The 'traceBinaryEventIO' function emits a binary message to the eventlog,
-- if eventlog profiling is available and enabled at runtime.
--
-- Compared to 'traceBinaryEvent', 'traceBinaryEventIO' sequences the event with
-- respect to other IO actions.
--
-- Also note that this function doesn't evaluate the 'B.ByteString' if user
-- tracing in evnetlog is disabled.
--
-- The input should be shorter than \(2^{16}\) bytes. Otherwise the RTS
-- generates a broken eventlog.
traceBinaryEventIO :: B.ByteString -> IO ()
traceBinaryEventIO :: ByteString -> IO ()
traceBinaryEventIO ByteString
bytes = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
userTracingEnabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
traceBinaryEventIO' ByteString
bytes

traceBinaryEventIO' :: B.ByteString -> IO ()
traceBinaryEventIO' :: ByteString -> IO ()
traceBinaryEventIO' ByteString
bytes =
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bytes ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr Addr#
p, I# Int#
n) -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Addr# -> Int# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Int# -> State# d -> State# d
traceBinaryEvent# Addr#
p Int#
n State# RealWorld
s of
      State# RealWorld
s' -> (# State# RealWorld
s', () #)