tracy-profiler (empty) → 0.1.0.0

raw patch · 10 files changed

+1035/−0 lines, 10 filesdep +basedep +bytestringdep +randombinary-added

Dependencies added: base, bytestring, random, text, tracy-profiler, webcolor-labels

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +101/−0
readme.png binary
src/System/Tracy.hs +278/−0
src/System/Tracy/FFI.hs +283/−0
src/System/Tracy/FFI/Types.hsc +69/−0
src/System/Tracy/Zone.hs +125/−0
test/Readme.hs +25/−0
tracy-profiler.cabal +117/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `tracy-profiler`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 - 2025-10-30++Initial release.

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2025 IC Rainbow++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,101 @@+# tracy-profiler++Haskell bindings for [Tracy frame profiler](https://github.com/wolfpld/tracy).++## Setup++### Installing++You can install the prebuilt package from your distribution if it has one:++```sh+sudo apt install libtracy-dev tracy-capture+```++Or you can [download] and build one yourself and point your project to it:++[download]: https://github.com/wolfpld/tracy/++```yaml+extra-lib-dirs:+- upstream/tracy/build+extra-include-dirs:+- upstream/tracy/public/tracy+```++This way you can customize configuration.+Make sure you update package flags to match.++Either way, you have to ensure that `tracy-capture` is built with the same version.+Otherwise it will connect and immediately refuse to record anything.++### Flags++The flags must match whatever the library has been built with.++By default all the instrumentation wrappers do nothing.+That means you don't have to `ifdef` your code to remove the wrappers when they're not needed.++You have to set the `enable` flag in your project for the data to be collected.++```yaml+flags:+  tracy-profiler:+    enable: true+    # manual_lifetime: false+    # fibers: false+```++## Instrumentation++Use the functions from `System.Tracy` and `System.Tracy.Zone` to collect data:++```haskell+{-# LANGUAGE CPP #-}               -- __LINE__ and __FILE__ macros+{-# LANGUAGE MagicHash #-}         -- "static strings"#+{-# LANGUAGE OverloadedLabels #-}  -- #fuchsia colors+{-# LANGUAGE OverloadedStrings #-} -- "yes"++module Main where++import qualified System.Tracy as Tracy+import qualified Data.Text as Text++main :: IO ()+main = Tracy.withProfiler $ do+  Tracy.waitConnected_       -- wait for the tracy-capture to connect+  Tracy.messageL "hi there"# -- static strings require no copying to be logged+  mapM_ runFrame [0..600]++runFrame :: Int -> IO ()+runFrame ix = Tracy.withSrcLoc_ __LINE__ __FILE__ "runFrame" #fcc do+  Tracy.frameMark_+  let factorial = product [1 .. toInteger ix]+  let !digits = length (show factorial)+  Tracy.message . Text.pack $+    -- runtime strings will require some memcpy'ng around, use sparingly on hot paths+    "!" <> show ix <> " has " <> show digits <> " digits"+  Tracy.plotInt "digits"# digits+```++## Collecting and viewing++Start `tracy-capture` before running the test to avoid empty areas where nothing happens:++```sh+tracy-capture -fo output.tracy &+```++Run the code, then upload the collected data to [the viewer](https://tracy.nereid.pl/).++You'll see something like this:++![screenshot](https://raw.githubusercontent.com/haskell-game/tracy-profiler/refs/heads/main/readme.png)++> Are those are GC pauses we're looking at? 🤔++## RTFM++You really should go read the official [manual](https://github.com/wolfpld/tracy/blob/master/manual/tracy.md).++Yes, BEFORE you run into corrupted memory, surprising grouppings, or otherwise botched profiling runs.

+ readme.png view

binary file changed (absent → 656333 bytes)

+ src/System/Tracy.hs view

@@ -0,0 +1,278 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module System.Tracy+  ( withProfiler+  , connected+  , waitConnected+  , waitConnected_++  , setThreadName+  , appInfo++  , Zone.withSrcLoc_++  , frameMark+  , frameMark_+  , frameMarkStart+  , frameMarkEnd++  , message+  , messageC+  , messageL+  , messageLC++  , plot+  , plotFloat+  , plotInt+  , plotIntegral+  , plotConfig+  , PlotFormat(..)++#ifdef TRACY_FIBERS+  , fiberEnter+  , fiberLeave+#endif++  , Color+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Foreign qualified as Text+import Foreign (nullPtr)+import Foreign.C.ConstPtr (ConstPtr(..))+import GHC.Exts (Ptr(..), Addr#)+import System.Timeout (timeout)++import System.Tracy.FFI qualified as FFI+import System.Tracy.FFI.Types (Color, PlotFormat(..))+import System.Tracy.Zone qualified as Zone++#if defined(TRACY_ENABLE) && defined(TRACY_MANUAL_LIFETIME)+import Control.Exception (bracket_)+#endif++{- | Start/stop profiler when TRACY_MANUAL_LIFETIME is enabled.+Otherwise does nothing.+-}+withProfiler :: IO a -> IO a+withProfiler action =+#if defined(TRACY_ENABLE) && defined(TRACY_MANUAL_LIFETIME)+  bracket_ FFI.startupProfiler FFI.shutdownProfiler action+#else+  action+#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 = pure ()+#endif++{-# INLINE frameMarkEnd #-}+frameMarkEnd :: MonadIO m => Addr# -> m ()+#if defined(TRACY_ENABLE)+frameMarkEnd name = liftIO $ FFI.emitFrameMarkEnd (ConstPtr $ Ptr name)+#else+frameMarkEnd = pure ()+#endif++-- TODO: nicer wrapper for emitFrameImage++{-# INLINE message #-}+message :: MonadIO m => Text -> m ()+#if defined(TRACY_ENABLE)+message txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.emitMessage (ConstPtr txtPtr) (fromIntegral txtSz) 0+#else+message _txt = pure ()+#endif++{-# INLINE messageC #-}+messageC :: MonadIO m => Color -> Text -> m ()+#if defined(TRACY_ENABLE)+messageC color txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.emitMessageC (ConstPtr txtPtr) (fromIntegral txtSz) color 0+#else+messageC _txt = pure ()+#endif+++{-# INLINE messageL #-}+messageL :: MonadIO m => Addr# -> m ()+#if defined(TRACY_ENABLE)+messageL txt = liftIO $+  FFI.emitMessageL (ConstPtr (Ptr txt)) 0+#else+messageL _txt = pure ()+#endif++{-# INLINE messageLC #-}+messageLC :: MonadIO m => Color -> Addr# -> m ()+#if defined(TRACY_ENABLE)+messageLC color txt = liftIO $+  FFI.emitMessageLC (ConstPtr (Ptr txt)) color 0+#else+messageLC _color _txt = 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 = 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 = pure ()+#endif++{-# INLINE plotInt #-}+plotInt :: MonadIO m => Addr# -> Int -> m ()+plotInt = plotIntegral++{-# INLINE plotIntegral #-}+plotIntegral :: (Integral a, MonadIO m) => Addr# -> a -> m ()+#if defined(TRACY_ENABLE)+plotIntegral name val = liftIO $+  FFI.emitPlotInt (ConstPtr (Ptr name)) (fromIntegral val)+#else+plotIntegral _name = 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) (fromIntegral 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 name val = liftIO $+  FFI.fiberLeave+#else+fiberLeave = pure ()+#endif+#endif

+ src/System/Tracy/FFI.hs view

@@ -0,0 +1,283 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}++module System.Tracy.FFI where++import Data.Int+import Data.Word+import Foreign.C+import Foreign.C.ConstPtr (ConstPtr(..))++import System.Tracy.FFI.Types++----------------------------------------------------------------++foreign import ccall "tracy/TracyC.h ___tracy_set_thread_name"+  setThreadName+    :: ConstPtr CChar -- ^ name+    -> IO ()++----------------------------------------------------------------++#ifdef TRACY_MANUAL_LIFETIME+foreign import ccall unsafe "___tracy_startup_profiler"+  startupProfiler+    :: IO ()++foreign import ccall unsafe "___tracy_shutdown_profiler"+  shutdownProfiler+    :: IO ()++foreign import ccall unsafe "___tracy_profiler_started"+  profilerStarted+    :: Int+#else+profilerStarted :: Int+profilerStarted = 1+#endif++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_alloc_srcloc"+  allocSrcloc+    :: Word32         -- ^ line+    -> ConstPtr CChar -- ^ source+    -> CSize          -- ^ sourceSz+    -> ConstPtr CChar -- ^ function+    -> CSize          -- ^ functionSz+    -> Color          -- ^ color+    -> IO SrcLoc++foreign import ccall unsafe "___tracy_alloc_srcloc_name"+  allocSrclocName+    :: Word32         -- ^ line+    -> ConstPtr CChar -- ^ source+    -> CSize          -- ^ sourceSz+    -> ConstPtr CChar -- ^ function+    -> CSize          -- ^ functionSz+    -> ConstPtr CChar -- ^ name+    -> CSize          -- ^ nameSz+    -> Color          -- ^ color+    -> IO SrcLoc++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_emit_zone_begin"+  emitZoneBegin+    :: ConstPtr SourceLocationData -- ^ srcloc+    -> Int                         -- ^ active+    -> IO TracyCZoneCtx++foreign import ccall unsafe "___tracy_emit_zone_begin_callstack"+  emitZoneBeginCallstack+    :: ConstPtr SourceLocationData -- ^ srcloc+    -> Int                         -- ^ depth+    -> Int                         -- ^ active+    -> IO TracyCZoneCtx++foreign import ccall unsafe "___tracy_emit_zone_begin_alloc"+  emitZoneBeginAlloc+    :: SrcLoc -- ^ srcloc+    -> Int    -- ^ active+    -> IO TracyCZoneCtx++foreign import ccall unsafe "___tracy_emit_zone_begin_alloc_callstack"+  emitZoneBeginAllocCallstack+    :: SrcLoc -- ^ srcloc+    -> Int    -- ^ depth+    -> Int    -- ^ active+    -> IO TracyCZoneCtx++foreign import ccall unsafe "___tracy_emit_zone_end"+  emitZoneEnd+    :: TracyCZoneCtx+    -> IO ()++foreign import ccall unsafe "___tracy_emit_zone_text"+  emitZoneText+    :: TracyCZoneCtx+    -> ConstPtr CChar+    -> CSize+    -> IO ()++foreign import ccall unsafe "___tracy_emit_zone_name"+  emitZoneName+    :: TracyCZoneCtx+    -> ConstPtr CChar+    -> CSize+    -> IO ()++foreign import ccall unsafe "___tracy_emit_zone_color"+  emitZoneColor+    :: TracyCZoneCtx+    -> Color+    -> IO ()++foreign import ccall unsafe "___tracy_emit_zone_value"+  emitZoneValue+    :: TracyCZoneCtx+    -> Word64+    -> IO ()++----------------------------------------------------------------++{-+TRACY_API void ___tracy_emit_gpu_zone_begin( const struct ___tracy_gpu_zone_begin_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_callstack( const struct ___tracy_gpu_zone_begin_callstack_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_alloc( const struct ___tracy_gpu_zone_begin_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_alloc_callstack( const struct ___tracy_gpu_zone_begin_callstack_data );+TRACY_API void ___tracy_emit_gpu_zone_end( const struct ___tracy_gpu_zone_end_data data );+TRACY_API void ___tracy_emit_gpu_time( const struct ___tracy_gpu_time_data );+TRACY_API void ___tracy_emit_gpu_new_context( const struct ___tracy_gpu_new_context_data );+TRACY_API void ___tracy_emit_gpu_context_name( const struct ___tracy_gpu_context_name_data );+TRACY_API void ___tracy_emit_gpu_calibration( const struct ___tracy_gpu_calibration_data );+TRACY_API void ___tracy_emit_gpu_time_sync( const struct ___tracy_gpu_time_sync_data );++TRACY_API void ___tracy_emit_gpu_zone_begin_serial( const struct ___tracy_gpu_zone_begin_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_callstack_serial( const struct ___tracy_gpu_zone_begin_callstack_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_alloc_serial( const struct ___tracy_gpu_zone_begin_data );+TRACY_API void ___tracy_emit_gpu_zone_begin_alloc_callstack_serial( const struct ___tracy_gpu_zone_begin_callstack_data );+TRACY_API void ___tracy_emit_gpu_zone_end_serial( const struct ___tracy_gpu_zone_end_data data );+TRACY_API void ___tracy_emit_gpu_time_serial( const struct ___tracy_gpu_time_data );+TRACY_API void ___tracy_emit_gpu_new_context_serial( const struct ___tracy_gpu_new_context_data );+TRACY_API void ___tracy_emit_gpu_context_name_serial( const struct ___tracy_gpu_context_name_data );+TRACY_API void ___tracy_emit_gpu_calibration_serial( const struct ___tracy_gpu_calibration_data );+TRACY_API void ___tracy_emit_gpu_time_sync_serial( const struct ___tracy_gpu_time_sync_data );+-}++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_connected"+  connected+    :: IO Int++----------------------------------------------------------------++{-+TRACY_API void ___tracy_emit_memory_alloc( const void* ptr, size_t size, int secure );+TRACY_API void ___tracy_emit_memory_alloc_callstack( const void* ptr, size_t size, int depth, int secure );+TRACY_API void ___tracy_emit_memory_free( const void* ptr, int secure );+TRACY_API void ___tracy_emit_memory_free_callstack( const void* ptr, int depth, int secure );+TRACY_API void ___tracy_emit_memory_alloc_named( const void* ptr, size_t size, int secure, const char* name );+TRACY_API void ___tracy_emit_memory_alloc_callstack_named( const void* ptr, size_t size, int depth, int secure, const char* name );+TRACY_API void ___tracy_emit_memory_free_named( const void* ptr, int secure, const char* name );+TRACY_API void ___tracy_emit_memory_free_callstack_named( const void* ptr, int depth, int secure, const char* name );+-}++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_emit_message"+  emitMessage+    :: ConstPtr CChar -- ^ txt+    -> CSize          -- ^ size+    -> CInt           -- ^ callstack+    -> IO ()++foreign import ccall unsafe "___tracy_emit_messageL"+  emitMessageL+    :: ConstPtr CChar -- ^ txt+    -> CInt           -- ^ callstack+    -> IO ()++foreign import ccall unsafe "___tracy_emit_messageC"+  emitMessageC+    :: ConstPtr CChar -- ^ txt+    -> CSize          -- ^ size+    -> Color          -- ^ color+    -> CInt           -- ^ callstack+    -> IO ()++foreign import ccall unsafe "___tracy_emit_messageLC"+  emitMessageLC+    :: ConstPtr CChar -- ^ txt+    -> Color          -- ^ color+    -> CInt           -- ^ callstack+    -> IO ()++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_emit_frame_mark"+  emitFrameMark+    :: ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_frame_mark_start"+  emitFrameMarkStart+    :: ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_frame_mark_end"+  emitFrameMarkEnd+    :: ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_frame_image"+  emitFrameImage+    :: ConstPtr () -- ^ image+    -> Word16      -- ^ w+    -> Word16      -- ^ h+    -> Word8       -- ^ offset+    -> CInt        -- ^ flip+    -> IO ()++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_emit_plot"+  emitPlot+    :: ConstPtr CChar -- ^ name+    -> Double         -- ^ val+    -> IO ()++foreign import ccall unsafe "___tracy_emit_plot_float"+  emitPlotFloat+    :: ConstPtr CChar -- ^ name+    -> Float          -- ^ val+    -> IO ()++foreign import ccall unsafe "___tracy_emit_plot_int"+  emitPlotInt+    :: ConstPtr CChar -- ^ name+    -> Int64          -- ^ val+    -> IO ()++foreign import ccall unsafe "___tracy_emit_plot_config"+  emitPlotConfig+    :: ConstPtr CChar -- ^ name+    -> CInt           -- ^ type+    -> CInt           -- ^ step+    -> CInt           -- ^ fill+    -> Color          -- ^ color+    -> IO ()++-- XXX: yes, in the same block with emit_plot+foreign import ccall unsafe "___tracy_emit_message_appinfo"+  emitMessageAppinfo+    :: ConstPtr CChar -- ^ txt+    -> CSize          -- ^ size+    -> IO ()++----------------------------------------------------------------++{-+TRACY_API struct __tracy_lockable_context_data* ___tracy_announce_lockable_ctx( const struct ___tracy_source_location_data* srcloc );+TRACY_API void ___tracy_terminate_lockable_ctx( struct __tracy_lockable_context_data* lockdata );+TRACY_API int ___tracy_before_lock_lockable_ctx( struct __tracy_lockable_context_data* lockdata );+TRACY_API void ___tracy_after_lock_lockable_ctx( struct __tracy_lockable_context_data* lockdata );+TRACY_API void ___tracy_after_unlock_lockable_ctx( struct __tracy_lockable_context_data* lockdata );+TRACY_API void ___tracy_after_try_lock_lockable_ctx( struct __tracy_lockable_context_data* lockdata, int acquired );+TRACY_API void ___tracy_mark_lockable_ctx( struct __tracy_lockable_context_data* lockdata, const struct ___tracy_source_location_data* srcloc );+TRACY_API void ___tracy_custom_name_lockable_ctx( struct __tracy_lockable_context_data* lockdata, const char* name, size_t nameSz );+-}++----------------------------------------------------------------++#ifdef TRACY_FIBERS+foreign import ccall unsafe "___tracy_fiber_enter"+  fiberEnter+    :: ConstPtr CChar -- ^ fiber+    -> IO ()++foreign import ccall unsafe "___tracy_fiber_leave"+  fiberLeave+    :: IO ()+#endif

+ src/System/Tracy/FFI/Types.hsc view

@@ -0,0 +1,69 @@+module System.Tracy.FFI.Types where++import Data.Word+import Foreign+import Foreign.C++import WebColor.Labels+import GHC.OverloadedLabels++#define TRACY_ENABLE+#include <tracy/TracyC.h>++newtype Color = Color Word32+  deriving (Show)+  deriving newtype (Eq, Ord, Storable, Num)++instance IsWebColorAlpha s => IsLabel s Color where+  fromLabel = webColorAlpha @s \r g b a ->+    Color $+      shiftL (fromIntegral a) 24 .|.+      shiftL (fromIntegral b) 16 .|.+      shiftL (fromIntegral g)  8 .|.+      fromIntegral r++newtype SrcLoc = SrcLoc Word64+  deriving (Show)+  deriving newtype (Eq, Ord, Storable)++data SourceLocationData = SourceLocationData+  { name     :: Ptr CChar+  , function :: Ptr CChar+  , file     :: Ptr CChar+  , line     :: Word32+  , color    :: Word32+  }++instance Storable SourceLocationData where+  sizeOf (~_undef) = (#size struct ___tracy_source_location_data)++  alignment (~_undef) = (#alignment struct ___tracy_source_location_data)++  peek ptr = do+    name     <- (#peek struct ___tracy_source_location_data, name) ptr+    function <- (#peek struct ___tracy_source_location_data, function) ptr+    file     <- (#peek struct ___tracy_source_location_data, file) ptr+    line     <- (#peek struct ___tracy_source_location_data, line) ptr+    color    <- (#peek struct ___tracy_source_location_data, color) ptr+    pure SourceLocationData{..}++  poke ptr SourceLocationData{..} = do+    (#poke struct ___tracy_source_location_data, name) ptr name+    (#poke struct ___tracy_source_location_data, function) ptr function+    (#poke struct ___tracy_source_location_data, file) ptr file+    (#poke struct ___tracy_source_location_data, line) ptr line+    (#poke struct ___tracy_source_location_data, color) ptr color++newtype TracyCZoneCtx = TracyCZoneCtx (Ptr TracyCZoneCtx)+  deriving (Show)+  deriving newtype (Eq, Ord, Storable)++nullTracyCZoneCtx :: TracyCZoneCtx+nullTracyCZoneCtx = TracyCZoneCtx nullPtr++data PlotFormat+  = PlotFormatNumber -- ^ values will be displayed as plain numbers.+  | PlotFormatMemory -- ^ treats the values as memory sizes. Will display kilobytes, megabytes, etc.+  | PlotFormatPercentage -- ^ values will be displayed as percentage (with value @100@ being equal to 100%).+  | PlotFormatWatt+  deriving (Eq, Ord, Show, Enum, Bounded)

+ src/System/Tracy/Zone.hs view

@@ -0,0 +1,125 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}++module System.Tracy.Zone+  ( -- * Declare zones+    withSrcLoc_++    -- * Update zone context+  , text+  , name+  , color+  , value++    -- * Internals+  , allocSrcloc+  ) where++import Control.Exception (bracket)+import Control.Monad.IO.Class (MonadIO(..))+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.Text (Text)+import Data.Text.Foreign qualified as Text+import Data.Word+import Foreign.C.ConstPtr (ConstPtr(..))++import System.Tracy.FFI qualified as FFI+import System.Tracy.FFI.Types qualified as FFI++{- | Allocate SrcLoc and run a Zone with it.++It will produce a @?zoneCtx@ implicit for the zone functions to work.++@+{-# LANGUAGE CPP #-}++import System.Tracy.Zone qualified as Zone++rendering = Zone.withSrcLoc_ \_\_LINE\_\_ \_\_FILE\_\_ "rendering" #yellow do+  -- ...+@+-}+withSrcLoc_+  :: Word32+  -> ByteString+  -> ByteString+  -> FFI.Color+  -> ((?zoneCtx :: FFI.TracyCZoneCtx) => IO a)+  -> IO a+#ifndef TRACY_ENABLE+withSrcLoc_ _line _file _function action = action+#else+withSrcLoc_ line file function col action = do+  srcloc <- allocSrcloc line file function Nothing col+  bracket+    (FFI.emitZoneBeginAlloc srcloc 1)+    FFI.emitZoneEnd+    (\ctx -> let ?zoneCtx = ctx in action)+#endif++{- | Prepare a single-use location identifier++Returns a source location identifier corresponding to an *allocated source location*.+As these functions do not require the provided string data to be available after they return, the calling code is free to deallocate them at any time afterward.+This way, the string lifetime requirements described in section 3.1 are relaxed.++The variable representing an allocated source location is of an opaque type.+After it is passed to one of the zone begin functions, its value *cannot be reused* (the variable is consumed).+You must allocate a new source location for each zone begin event, even if the location data would be the same as in the previous instance.+-}+allocSrcloc+  :: Word32+  -> ByteString+  -> ByteString+  -> Maybe ByteString+  -> FFI.Color+  -> IO FFI.SrcLoc+allocSrcloc line source function name_ col =+  unsafeUseAsCStringLen source \(sourcePtr, sourceSz) ->+  unsafeUseAsCStringLen function \(functionPtr, functionSz) ->+    case name_ of+      Nothing ->+        FFI.allocSrcloc+          line+          (ConstPtr sourcePtr) (fromIntegral sourceSz)+          (ConstPtr functionPtr) (fromIntegral functionSz)+          col+      Just name' ->+        unsafeUseAsCStringLen name' \(namePtr, nameSz) ->+          FFI.allocSrclocName+            line+            (ConstPtr sourcePtr) (fromIntegral sourceSz)+            (ConstPtr functionPtr) (fromIntegral functionSz)+            (ConstPtr namePtr) (fromIntegral nameSz)+            col++{- TODO: Wrap emitZoneBegin++This needs keeping SourceLocationData structures filled with pinned pointers.+Otherwise the data would be pulled much later, outside a potential with/bracket scope+with garbage/crashes as a result.++Some nice solution would require interning SourceLocationData and its data.+Otherwise it's a copying galore and Tracy may fail to deduplicate the locations.+-}++{-# INLINE text #-}+text :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => Text -> m ()+text txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.emitZoneText ?zoneCtx (ConstPtr txtPtr) (fromIntegral txtSz)++{-# INLINE name #-}+name :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => Text -> m ()+name txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.emitZoneName ?zoneCtx (ConstPtr txtPtr) (fromIntegral txtSz)++{-# INLINE color #-}+color :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => FFI.Color -> m ()+color col = liftIO $ FFI.emitZoneColor ?zoneCtx col++{-# INLINE value #-}+value :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => Word64 -> m ()+value val = liftIO $ FFI.emitZoneValue ?zoneCtx val

+ test/Readme.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}               -- __LINE__ and __FILE__ macros+{-# LANGUAGE MagicHash #-}         -- "static strings"#+{-# LANGUAGE OverloadedLabels #-}  -- #fuchsia colors+{-# LANGUAGE OverloadedStrings #-} -- "yes"++module Main where++import qualified System.Tracy as Tracy+import qualified Data.Text as Text++main :: IO ()+main = Tracy.withProfiler $ do+  Tracy.waitConnected_       -- wait for the tracy-capture to connect+  Tracy.messageL "hi there"# -- static strings require no copying to be logged+  mapM_ runFrame [0..600]++runFrame :: Int -> IO ()+runFrame ix = Tracy.withSrcLoc_ __LINE__ __FILE__ "runFrame" #fcc do+  Tracy.frameMark_+  let factorial = product [1 .. toInteger ix]+  let !digits = length (show factorial)+  Tracy.message . Text.pack $+    -- runtime strings will require some memcpy'ng around, use sparingly on hot paths+    "!" <> show ix <> " has " <> show digits <> " digits"+  Tracy.plotInt "digits"# digits

+ tracy-profiler.cabal view

@@ -0,0 +1,117 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           tracy-profiler+version:        0.1.0.0+synopsis:       Haskell bindings for Tracy frame profiler+category:       Profiling+homepage:       https://github.com/haskell-game/tracy-profiler#readme+bug-reports:    https://github.com/haskell-game/tracy-profiler/issues+author:         IC Rainbow+maintainer:     aenor.realm@gmail.com+copyright:      2025 IC Rainbow+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    CHANGELOG.md+    readme.png++source-repository head+  type: git+  location: https://github.com/haskell-game/tracy-profiler++flag enable+  description: Enable to actually call the Tracy functions and produce data. Otherwise the wrappers will be no-ops.+  manual: True+  default: False++flag fibers+  description: Enable if your libtracyclient has this enabled.+  manual: True+  default: False++flag has_callstack+  description: Enable if your libtracyclient has this enabled.+  manual: True+  default: False++flag manual_lifetime+  description: Manually manage profiler lifetime. Enable if your libtracyclient has this enabled.+  manual: True+  default: False++library+  exposed-modules:+      System.Tracy+      System.Tracy.FFI+      System.Tracy.FFI.Types+      System.Tracy.Zone+  other-modules:+      Paths_tracy_profiler+  autogen-modules:+      Paths_tracy_profiler+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DerivingStrategies+      DuplicateRecordFields+      ImportQualifiedPost+      LambdaCase+      NoFieldSelectors+      OverloadedLabels+      OverloadedStrings+      RecordWildCards+      StrictData+      ImplicitParams+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  extra-libraries:+      TracyClient+  build-depends:+      base >=4.16 && <5+    , bytestring+    , text >=2.0 && <3+    , webcolor-labels+  default-language: GHC2021+  if flag(manual_lifetime)+    cpp-options: -DTRACY_MANUAL_LIFETIME+  if flag(enable)+    cpp-options: -DTRACY_ENABLE+  if flag(fibers)+    cpp-options: -DTRACY_FIBERS+  if flag(has_callstack)+    cpp-options: -DTRACY_HAS_CALLSTACK++test-suite tracy-profiler-test+  type: exitcode-stdio-1.0+  main-is: Readme.hs+  other-modules:+      Paths_tracy_profiler+  autogen-modules:+      Paths_tracy_profiler+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DerivingStrategies+      DuplicateRecordFields+      ImportQualifiedPost+      LambdaCase+      NoFieldSelectors+      OverloadedLabels+      OverloadedStrings+      RecordWildCards+      StrictData+      ImplicitParams+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.16 && <5+    , random+    , text+    , tracy-profiler+  default-language: GHC2021