diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/readme.png b/readme.png new file mode 100644 Binary files /dev/null and b/readme.png differ diff --git a/src/System/Tracy.hs b/src/System/Tracy.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy.hs @@ -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 diff --git a/src/System/Tracy/FFI.hs b/src/System/Tracy/FFI.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/FFI.hs @@ -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 diff --git a/src/System/Tracy/FFI/Types.hsc b/src/System/Tracy/FFI/Types.hsc new file mode 100644 --- /dev/null +++ b/src/System/Tracy/FFI/Types.hsc @@ -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 + +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) diff --git a/src/System/Tracy/Zone.hs b/src/System/Tracy/Zone.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/Zone.hs @@ -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 diff --git a/test/Readme.hs b/test/Readme.hs new file mode 100644 --- /dev/null +++ b/test/Readme.hs @@ -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 diff --git a/tracy-profiler.cabal b/tracy-profiler.cabal new file mode 100644 --- /dev/null +++ b/tracy-profiler.cabal @@ -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