tracy-profiler 0.1.1.0 → 0.1.2.0

raw patch · 9 files changed

+304/−46 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +18/−5
• src/System/Tracy.hs +1/−1
• src/System/Tracy/FFI.hs +59/−10
• src/System/Tracy/FFI/Types.hsc +8/−3
• src/System/Tracy/Memory.hs +84/−0
• src/System/Tracy/Zone.hs +90/−18
• test/Readme.hs +4/−3
• tracy-profiler.cabal +29/−6

@@ -6,6 +6,17 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.1.2.0 - 2025-11-01++- Fixed byte order in IsLabel Color instance.+- Move library dependencies under a flag.+  The package takes extra effort to remove traces of itself unless enabled.+- Added a safety net around zones.+  Controlled with flags: zones_pedantic (disable to silently skip) and zones_unsafe (enable to remove the check).+- Added `withSrcLoc` which avoids CPP.+- Renamed `withSrcLoc_` to `withSrcLocImpl`, don't use.+- `Added System.Tracy.Memory` wrappers (sans the callback variants).+ ## 0.1.1.0 - 2025-10-30  - Fixes for copypasta in `#ifndef TRACE_ENABLE` sections.

@@ -9,13 +9,25 @@ You can install the prebuilt package from your distribution if it has one:  ```sh-sudo apt install libtracy-dev tracy-capture+sudo apt install libtracy-dev tracy-capture tracy-profiler ```  Or you can [download] and build one yourself and point your project to it:  [download]: https://github.com/wolfpld/tracy/ +```sh+mkdir -p upstream+cd upstream && git clone --recursive https://github.com/wolfpld/tracy+cmake -B upstream/tracy/build -S upstream/tracy \+  -DCMAKE_POSITION_INDEPENDENT_CODE=ON \+  -DTRACY_ONLY_LOCALHOST=ON \+  -DTRACY_ENABLE=ON \+  -DTRACY_MANUAL_LIFETIME=ON \+  -DTRACY_DELAYED_INIT=ON+cmake --build upstream/tracy/build --config Release+```+ ```yaml extra-lib-dirs: - upstream/tracy/build@@ -26,7 +38,7 @@ 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.+Either way, you have to ensure that `tracy-capture`/`tracy-profiler` is built with the same version. Otherwise it will connect and immediately refuse to record anything.  ### Flags@@ -64,11 +76,12 @@ 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]+  Tracy.withSrcLoc "main.nowhereInParticular" #f0fa do+    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+runFrame ix = Tracy.withSrcLoc "runFrame" #fcc do   Tracy.frameMark_   let factorial = product [1 .. toInteger ix]   let !digits = length (show factorial)

@@ -10,7 +10,7 @@   , setThreadName   , appInfo -  , Zone.withSrcLoc_+  , Zone.withSrcLoc    , frameMark   , frameMark_

@@ -153,16 +153,65 @@  ---------------------------------------------------------------- -{--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_memory_alloc"+  emitMemoryAlloc+    :: ConstPtr () -- ^ ptr+    -> CSize       -- ^ size+    -> CInt        -- ^ secure+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_alloc_callstack"+  emitMemoryAllocCallstack+    :: ConstPtr () -- ^ ptr+    -> CSize       -- ^ size+    -> CInt        -- ^ depth+    -> CInt        -- ^ secure+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_free"+  emitMemoryFree+    :: ConstPtr () -- ^ ptr+    -> CInt        -- ^ secure+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_free_callstack"+  emitMemoryFreeCallstack+    :: ConstPtr () -- ^ ptr+    -> CInt        -- ^ depth+    -> CInt        -- ^ secure+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_alloc_named"+  emitMemoryAllocNamed+    :: ConstPtr ()    -- ^ ptr+    -> CSize          -- ^ size+    -> CInt           -- ^ secure+    -> ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_alloc_callstack_named"+  emitMemoryAllocCallstackNamed+    :: ConstPtr ()    -- ^ ptr+    -> CSize          -- ^ size+    -> CInt           -- ^ depth+    -> CInt           -- ^ secure+    -> ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_free_named"+  emitMemoryFreeNamed+    :: ConstPtr ()    -- ^ ptr+    -> CInt           -- ^ secure+    -> ConstPtr CChar -- ^ name+    -> IO ()++foreign import ccall unsafe "___tracy_emit_memory_free_callstack_named"+  emitMemoryFreeCallstackNamed+    :: ConstPtr ()    -- ^ ptr+    -> CInt           -- ^ depth+    -> CInt           -- ^ secure+    -> ConstPtr CChar -- ^ name+    -> IO ()  ---------------------------------------------------------------- 

@@ -10,6 +10,11 @@ #define TRACY_ENABLE #include <tracy/TracyC.h> +{- | Packed 32-bit color++Hex literals can be used as @0xRRGGBB@.+Alternatively, "webcolors" notation is supported via labels: @#rgb@, @#rrggbb@, even some @#red@.+-} newtype Color = Color Word32   deriving (Show)   deriving newtype (Eq, Ord, Storable, Num)@@ -18,9 +23,9 @@   fromLabel = webColorAlpha @s \r g b a ->     Color $       shiftL (fromIntegral a) 24 .|.-      shiftL (fromIntegral b) 16 .|.+      shiftL (fromIntegral r) 16 .|.       shiftL (fromIntegral g)  8 .|.-      fromIntegral r+      fromIntegral b  newtype SrcLoc = SrcLoc Word64   deriving (Show)@@ -31,7 +36,7 @@   , function :: Ptr CChar   , file     :: Ptr CChar   , line     :: Word32-  , color    :: Word32+  , color    :: Color   }  instance Storable SourceLocationData where

@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++{-| Tracing memory allocations++https://github.com/wolfpld/tracy/blob/master/manual/tracy.md#memory-profiling-memoryprofiling+-}++module System.Tracy.Memory+  ( -- * Generic allocation tracing+    alloc+  , free+    -- * Memory pools+  , allocNamed+  , freeNamed+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Foreign.Ptr (Ptr)+import GHC.Exts (Addr#)++#ifdef TRACY_ENABLE+import GHC.Exts (Ptr(..))+import Foreign.Ptr (castPtr)+import Foreign.C.ConstPtr (ConstPtr(..))++import System.Tracy.FFI qualified as FFI+#endif++{-# INLINE alloc #-}+alloc+  :: MonadIO m+  => Bool  -- ^ secure+  -> Ptr a -- ^ address to register+  -> Int   -- ^ size+  -> m ()+#ifdef TRACY_ENABLE+alloc secure ptr size =+  liftIO $ FFI.emitMemoryAlloc (ConstPtr $ castPtr ptr) (fromIntegral size) (fromIntegral $ fromEnum secure)+#else+alloc _secure _ptr _size = pure ()+#endif++{-# INLINE free #-}+free+  :: MonadIO m+  => Bool  -- ^ secure+  -> Ptr a -- ^ address that was registered+  -> m ()+#ifdef TRACY_ENABLE+free secure ptr =+  liftIO $ FFI.emitMemoryFree (ConstPtr $ castPtr ptr) (fromIntegral $ fromEnum secure)+#else+free _secure _ptr = pure ()+#endif++{-# INLINE allocNamed #-}+allocNamed+  :: MonadIO m+  => Bool  -- ^ secure+  -> Ptr a -- ^ address to register+  -> Int   -- ^ size+  -> Addr# -- ^ memory pool name+  -> m ()+#ifdef TRACY_ENABLE+allocNamed secure ptr size name =+  liftIO $ FFI.emitMemoryAllocNamed (ConstPtr $ castPtr ptr) (fromIntegral size) (fromIntegral $ fromEnum secure) (ConstPtr $ Ptr name)+#else+allocNamed _secure _ptr _size _name = pure ()+#endif++{-# INLINE freeNamed #-}+freeNamed+  :: MonadIO m+  => Bool  -- ^ secure+  -> Ptr a -- ^ address that was registered+  -> Addr# -- ^ memory pool name+  -> m ()+#ifdef TRACY_ENABLE+freeNamed secure ptr name =+  liftIO $ FFI.emitMemoryFreeNamed (ConstPtr $ castPtr ptr) (fromIntegral $ fromEnum secure) (ConstPtr $ Ptr name)+#else+freeNamed _secure _ptr _name = pure ()+#endif

@@ -3,7 +3,7 @@  module System.Tracy.Zone   ( -- * Declare zones-    withSrcLoc_+    withSrcLoc      -- * Update zone context   , text@@ -12,6 +12,7 @@   , value      -- * Internals+  , withSrcLocImpl   , allocSrcloc   ) where @@ -26,7 +27,20 @@ #ifdef TRACY_ENABLE import Control.Exception (bracket) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.ByteString.Char8 qualified as ByteString+import GHC.Stack+import GHC.Stack.Types qualified as GHC++#ifndef ZONES_UNSAFE+import Control.Concurrent (isCurrentThreadBound)+#ifdef ZONES_PEDANTIC+import System.Exit (die)+-- pedantic #endif+-- !unsafe+#endif+-- enable+#endif  import System.Tracy.FFI qualified as FFI import System.Tracy.FFI.Types qualified as FFI@@ -36,38 +50,96 @@ It will produce a @?zoneCtx@ implicit for the zone functions to work.  @-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLabels #-} -- for colors+{-# LANGUAGE OverloadedStrings #-} -- for names  import System.Tracy.Zone qualified as Zone -rendering = Zone.withSrcLoc_ \_\_LINE\_\_ \_\_FILE\_\_ "rendering" #yellow do+rendering = Zone.withSrcLoc "rendering" #yellow do   -- ... @++NB: Zones can only be used on a bound thread.+Main thread is safe, but the rest should use one of forkOn/asyncBound/runInBoundThread. -}-{-# INLINE withSrcLoc_ #-}-withSrcLoc_ ::+{-# INLINE withSrcLoc #-}+withSrcLoc+#ifdef TRACY_ENABLE+  :: ( HasCallStack+     , MonadUnliftIO m+     )+#else+  :: ()+#endif+  => ByteString -- ^ Function name (if used as a top-level wrapper) or section name (in a middle of a @do@ block).+  -> FFI.Color+  -> ((?zoneCtx :: FFI.TracyCZoneCtx) => m a)+  -> m a #ifndef TRACY_ENABLE-  ()+withSrcLoc _function _col action = let ?zoneCtx = FFI.nullTracyCZoneCtx in action #else-  (MonadUnliftIO m)+withSrcLoc function col action = withRunInIO \inIO -> do+  -- XXX: breaking into non-public API from GHC.Stack.Types to short-circuit `srcLocFile` stringification+  case callStack of+    GHC.PushCallStack _myself GHC.SrcLoc{srcLocStartLine, srcLocFile} _next ->+      withSrcLocImpl+        (fromIntegral srcLocStartLine)+        (ByteString.pack srcLocFile) -- XXX: srcLocFile is originally an Addr#. So pack should be optimized down to FinalPtr too.+        function -- XXX: IsString instance has an unsafePackLiteral rule for string literals+        col+        inIO+        action+    _EmptyOrFreeze ->+      error "withSrcLoc ought to have HasCallStack in context" #endif-  => Word32++{- | Allocate SrcLoc and run a Zone with it.++This will copy the strings into a one-time temporary buffer and feed it into emitZoneBeginAlloc.+You'd better have those bytestrings come from static literals to avoid even more intermediate allocations.+-}+{-# INLINE withSrcLocImpl #-}+withSrcLocImpl+  :: Word32   -> ByteString   -> ByteString   -> FFI.Color+  -> (m a -> IO a)   -> ((?zoneCtx :: FFI.TracyCZoneCtx) => m a)-  -> m a+  -> IO a #ifndef TRACY_ENABLE-withSrcLoc_ _line _file _function _col action =-  let ?zoneCtx = FFI.nullTracyCZoneCtx-  in action+withSrcLocImpl _line _file _function _col inIO action =+  inIO $ let ?zoneCtx = FFI.nullTracyCZoneCtx in action #else-withSrcLoc_ line file function col action = withRunInIO \run -> do-  srcloc <- allocSrcloc line file function Nothing col-  bracket-    (FFI.emitZoneBeginAlloc srcloc 1)-    FFI.emitZoneEnd-    (\ctx -> run $ let ?zoneCtx = ctx in action)+withSrcLocImpl line file function col inIO action = do+#ifdef ZONES_UNSAFE+  runZone+#else+  bound <- isCurrentThreadBound+  if bound then+    runZone+  else+#ifdef ZONES_PEDANTIC+    {-+      XXX: Will not actually crash the whole program, only the thread.+      But at least there would be a console notice when this happens.+    -}+    die $ ByteString.unpack file <> ":" <> show line <> " Starting a zone on unbound thread"+#else+    inIO $ let ?zoneCtx = FFI.nullTracyCZoneCtx in action+#endif++-- ZONES_UNSAFE+#endif+  where+    {-# INLINE runZone #-}+    runZone = do+      srcloc <- allocSrcloc line file function Nothing col+      bracket+        (FFI.emitZoneBeginAlloc srcloc 1)+        FFI.emitZoneEnd+        (\ctx -> inIO $ let ?zoneCtx = ctx in action)+-- TRACY_ENABLE #endif  {- | Prepare a single-use location identifier

@@ -11,11 +11,12 @@ 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]+  Tracy.withSrcLoc "main.nowhereInParticular" #f0fa do+    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+runFrame ix = Tracy.withSrcLoc "runFrame" #fcc do   Tracy.frameMark_   let factorial = product [1 .. toInteger ix]   let !digits = length (show factorial)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           tracy-profiler-version:        0.1.1.0+version:        0.1.2.0 synopsis:       Haskell bindings for Tracy frame profiler category:       Profiling homepage:       https://github.com/haskell-game/tracy-profiler#readme@@ -45,11 +45,27 @@   manual: True   default: False +flag on_demand+  description: Don't generate and keep events if there's no connection. Enable if your libtracyclient has this enabled.+  manual: True+  default: False++flag zones_pedantic+  description: Crash when a zone is starting on an unbound thread.+  manual: True+  default: True++flag zones_unsafe+  description: Skip the bound-thread check for zones. This may crash the profile server with "zone ended twice" error.+  manual: True+  default: False+ library   exposed-modules:       System.Tracy       System.Tracy.FFI       System.Tracy.FFI.Types+      System.Tracy.Memory       System.Tracy.Zone   other-modules:       Paths_tracy_profiler@@ -69,9 +85,7 @@       RecordWildCards       StrictData       ImplicitParams-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints-  extra-libraries:-      TracyClient+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2   build-depends:       base >=4.16 && <5     , bytestring@@ -79,14 +93,23 @@     , unliftio-core     , webcolor-labels   default-language: GHC2021-  if flag(manual_lifetime)-    cpp-options: -DTRACY_MANUAL_LIFETIME   if flag(enable)     cpp-options: -DTRACY_ENABLE+    extra-libraries:+        TracyClient+        stdc+++  if flag(manual_lifetime)+    cpp-options: -DTRACY_MANUAL_LIFETIME+  if flag(on_demand)+    cpp-options: -DTRACY_ON_DEMAND   if flag(fibers)     cpp-options: -DTRACY_FIBERS   if flag(has_callstack)     cpp-options: -DTRACY_HAS_CALLSTACK+  if flag(zones_pedantic)+    cpp-options: -DZONES_PEDANTIC+  if flag(zones_unsafe)+    cpp-options: -DZONES_UNSAFE  test-suite tracy-profiler-test   type: exitcode-stdio-1.0