Tracy.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}

module System.Tracy
  ( -- * Profiler
    withProfiler
  , enabled
  , connected
  , waitConnected
  , waitConnected_

    -- * Program information
  , setThreadName
  , appInfo

    -- * Zones
  , Zone.withSrcLoc

    -- * Frames
  , frameMark
  , frameMark_
  , frameMarkStart
  , frameMarkEnd
  , frameImage

    -- * Messages
  , message
  , messageC
  , messageL
  , messageLC
  , logString
  , logStringL
  , MessageSeverity(..)

    -- * Time
  , getTime

    -- * Sampling profiler
  , beginSamplingProfiling
  , endSamplingProfiling

    -- * Plots
  , plot
  , plotFloat
  , plotInt
  , plotIntegral
  , plotConfig
  , PlotFormat(..)

#ifdef TRACY_FIBERS
    -- * Fibers
  , fiberEnter
  , fiberLeave
#endif

    -- * Colors
  , Color
  ) where

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Int (Int64)
import Data.Text (Text)
import Data.Word (Word8, Word16)
import GHC.Exts (Addr#, Ptr(..))

#if defined(TRACY_ENABLE)
import Control.Concurrent (threadDelay)
import Data.Maybe (fromMaybe)
import Data.Text.Foreign qualified as Text
import Foreign (castPtr, fromBool, nullPtr)
import Foreign.C.ConstPtr (ConstPtr(..))
import System.Timeout (timeout)
import System.Tracy.FFI qualified as FFI
import System.Tracy.FFI.Types (clampTextBytes)
#endif

import System.Tracy.FFI.Types (Color, MessageSeverity(..), PlotFormat(..))
import System.Tracy.Zone qualified as Zone

#if defined(TRACY_ENABLE) && defined(TRACY_MANUAL_LIFETIME)
import Control.Exception (bracket_)
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
#endif

{- | Start/stop profiler when TRACY_MANUAL_LIFETIME is enabled.
Otherwise does nothing.
-}
#if defined(TRACY_ENABLE) && defined(TRACY_MANUAL_LIFETIME)
withProfiler :: MonadUnliftIO m => m a -> m a
withProfiler action =
  withRunInIO \run ->
    bracket_ FFI.startupProfiler FFI.shutdownProfiler (run action)
#else
withProfiler :: a -> a
withProfiler = id
#endif

enabled :: Bool
#if defined(TRACY_ENABLE)
enabled = True
#else
enabled = False
#endif

{- | Check whether the profiler is connected.
-}
connected :: IO Bool
#if defined(TRACY_ENABLE)
connected = (/= 0) <$> FFI.connected
#else
connected = pure False
#endif

{- | Poll connection status repeatedly until the profiler is connected or the time is up.

Immediately returns False when Tracy is not enabled.
-}
waitConnected
  :: MonadIO m
  => Int       -- ^ Poll interval
  -> Maybe Int -- ^ Maximum waiting time
  -> m Bool
#if defined(TRACY_ENABLE)
waitConnected interval mtimeout =
  liftIO $
    case mtimeout of
      Nothing -> go
      Just t -> fromMaybe False <$> timeout t go
  where
    go = do
      conn <- connected
      if conn then
        pure True
      else
        threadDelay interval >> go
#else
waitConnected _interval _timeout = pure False -- XXX: ignore indefinite waiting
#endif

{- | Wait indefinitely until the profiler connects.

Useful for tests, benches, and other short-lifetime scripts.
-}
waitConnected_ :: IO ()
waitConnected_ = void $ waitConnected 100000 Nothing

setThreadName :: Addr# -> IO ()
#if defined(TRACY_ENABLE)
setThreadName name = FFI.setThreadName (ConstPtr (Ptr name))
#else
setThreadName _name = pure ()
#endif

{-# INLINE frameMark_ #-}
frameMark_ :: MonadIO m => m ()
#if defined(TRACY_ENABLE)
frameMark_ = liftIO $ FFI.emitFrameMark (ConstPtr nullPtr)
#else
frameMark_ = pure ()
#endif

{-# INLINE frameMark #-}
frameMark :: MonadIO m => Addr# -> m ()
#if defined(TRACY_ENABLE)
frameMark name = liftIO $ FFI.emitFrameMark (ConstPtr $ Ptr name)
#else
frameMark _name = pure ()
#endif

{-# INLINE frameMarkStart #-}
frameMarkStart :: MonadIO m => Addr# -> m ()
#if defined(TRACY_ENABLE)
frameMarkStart name = liftIO $ FFI.emitFrameMarkStart (ConstPtr $ Ptr name)
#else
frameMarkStart _name = pure ()
#endif

{-# INLINE frameMarkEnd #-}
frameMarkEnd :: MonadIO m => Addr# -> m ()
#if defined(TRACY_ENABLE)
frameMarkEnd name = liftIO $ FFI.emitFrameMarkEnd (ConstPtr $ Ptr name)
#else
frameMarkEnd _name = pure ()
#endif

{-# INLINE frameImage #-}
frameImage :: MonadIO m => Ptr pixels -> Word16 -> Word16 -> Word8 -> Bool -> m ()
#if defined(TRACY_ENABLE)
frameImage image width height lag flipped = liftIO $
  FFI.emitFrameImage (ConstPtr $ castPtr image) width height lag (fromBool flipped)
#else
frameImage _image _width _height _lag _flipped = pure ()
#endif

{-# INLINE message #-}
message :: MonadIO m => Text -> m ()
message = messageC 0

{-# INLINE messageC #-}
messageC :: MonadIO m => Color -> Text -> m ()
messageC = logString MessageSeverityInfo

{-# INLINE messageL #-}
messageL :: MonadIO m => Addr# -> m ()
messageL = messageLC 0

{-# INLINE messageLC #-}
messageLC :: MonadIO m => Color -> Addr# -> m ()
messageLC = logStringL MessageSeverityInfo

{-# INLINE logString #-}
logString :: MonadIO m => MessageSeverity -> Color -> Text -> m ()
#if defined(TRACY_ENABLE)
logString severity color txt = liftIO $
  Text.withCStringLen txt \(txtPtr, txtSz) ->
    FFI.emitLogString (fromIntegral $ fromEnum severity) color 0 (clampTextBytes txtSz) (ConstPtr txtPtr)
#else
logString _severity _color _txt = pure ()
#endif

{-# INLINE logStringL #-}
logStringL :: MonadIO m => MessageSeverity -> Color -> Addr# -> m ()
#if defined(TRACY_ENABLE)
logStringL severity color txt = liftIO $
  FFI.emitLogStringL (fromIntegral $ fromEnum severity) color 0 (ConstPtr (Ptr txt))
#else
logStringL _severity _color _txt = pure ()
#endif

{-# INLINE getTime #-}
getTime :: MonadIO m => m Int64
#if defined(TRACY_ENABLE)
getTime = liftIO FFI.getTime
#else
getTime = pure 0
#endif

beginSamplingProfiling :: MonadIO m => m Bool
#if defined(TRACY_ENABLE)
beginSamplingProfiling = liftIO $ (/= 0) <$> FFI.beginSamplingProfiling
#else
beginSamplingProfiling = pure False
#endif

endSamplingProfiling :: MonadIO m => m ()
#if defined(TRACY_ENABLE)
endSamplingProfiling = liftIO FFI.endSamplingProfiling
#else
endSamplingProfiling = pure ()
#endif

{-# INLINE plot #-}
plot :: MonadIO m => Addr# -> Double -> m ()
#if defined(TRACY_ENABLE)
plot name val = liftIO $
  FFI.emitPlot (ConstPtr (Ptr name)) val
#else
plot _name _val = pure ()
#endif

{-# INLINE plotFloat #-}
plotFloat :: MonadIO m => Addr# -> Float -> m ()
#if defined(TRACY_ENABLE)
plotFloat name val = liftIO $
  FFI.emitPlotFloat (ConstPtr (Ptr name)) val
#else
plotFloat _name _val = pure ()
#endif

{-# INLINE plotInt #-}
plotInt :: MonadIO m => Addr# -> Int -> m ()
plotInt = plotIntegral

{-# INLINE plotIntegral #-}
#if defined(TRACY_ENABLE)
plotIntegral :: (Integral a, MonadIO m) => Addr# -> a -> m ()
plotIntegral name val = liftIO $
  FFI.emitPlotInt (ConstPtr (Ptr name)) (fromIntegral val)
#else
plotIntegral :: Monad m => Addr# -> a -> m ()
plotIntegral _name _val = pure ()
#endif

{-# INLINE plotConfig #-}
plotConfig
  :: MonadIO m
  => Addr#
  -> PlotFormat
  -> Bool -- ^ Step
  -> Bool -- ^ Fill
  -> Color
  -> m ()
#if defined(TRACY_ENABLE)
plotConfig name pf step fill col = liftIO $
  FFI.emitPlotConfig
    (ConstPtr (Ptr name))
    (fromIntegral $ fromEnum pf)
    (fromIntegral $ fromEnum step)
    (fromIntegral $ fromEnum fill)
    col
#else
plotConfig _name _typ _step _fill _col = pure ()
#endif

{- | Record additional information about the profiled application,
  which will be available in the trace description.

  This can include data such as the source repository revision, the
  application's environment (dev/prod), etc.
-}
{-# INLINE appInfo #-}
appInfo :: MonadIO m => Text -> m ()
#if defined(TRACY_ENABLE)
appInfo txt = liftIO $
  Text.withCStringLen txt \(txtPtr, txtSz) ->
    FFI.emitMessageAppinfo (ConstPtr txtPtr) (clampTextBytes txtSz)
#else
appInfo _txt = pure ()
#endif

#ifdef TRACY_FIBERS
{-# INLINE fiberEnter #-}
fiberEnter :: MonadIO m => Addr# -> m ()
#if defined(TRACY_ENABLE)
fiberEnter name = liftIO $
  FFI.fiberEnter (ConstPtr (Ptr name))
#else
fiberEnter _name = pure ()
#endif

{-# INLINE fiberLeave #-}
fiberLeave :: MonadIO m => m ()
#if defined(TRACY_ENABLE)
fiberLeave = liftIO FFI.fiberLeave
#else
fiberLeave = pure ()
#endif
#endif