tracy-profiler 0.1.2.1 → 0.2.0.0

raw patch · 19 files changed

+1717/−244 lines, 19 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +51/−0
• README.md +100/−5
• cbits/gpu_shim.c +124/−0
• cbits/layout_check.c +14/−0
• cbits/section_shim.c +14/−0
• cbits/zone_shim.c +64/−0
• src/System/Tracy.hs +81/−28
• src/System/Tracy/FFI.hs +378/−68
• src/System/Tracy/FFI/Types.hs +164/−0
• src/System/Tracy/FFI/Types.hsc +0/−76
• src/System/Tracy/Gpu.hs +219/−0
• src/System/Tracy/Lock.hs +106/−0
• src/System/Tracy/Memory.hs +34/−21
• src/System/Tracy/Section.hs +80/−0
• src/System/Tracy/SharedLock.hs +147/−0
• src/System/Tracy/SourceLocation.hs +37/−0
• src/System/Tracy/Zone.hs +78/−39
• test/Readme.hs +7/−1
• tracy-profiler.cabal +19/−6

@@ -6,6 +6,57 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.2.0.0 - 2026-11-09++Now targets Tracy 0.15. The library, `tracy-capture` and `tracy-profiler` must all come from that release.++### Breaking++- Removed the `secure` argument from `System.Tracy.Memory.alloc`, `free`, `allocNamed` and `freeNamed`.+  Tracy dropped the distinction and always uses the secure code path.+- The matching `System.Tracy.FFI.emitMemory*` imports lost their `secure` argument.+- `System.Tracy.FFI.emitMessage`, `emitMessageL`, `emitMessageC` and `emitMessageLC` are replaced by `emitLogString` and `emitLogStringL`, following the upstream API.+  The `System.Tracy.message*` wrappers keep their types and log at the info severity.+- `System.Tracy.FFI.TracyCZoneCtx` has a different representation under the `on_demand` flag.+- `System.Tracy.FFI.connected` now returns `Int32`, matching the C function.+- `System.Tracy.FFI.profilerStarted` is now an `IO Int32` action.+  The old pure `Int` could keep its first result under `manual_lifetime` even after the profiler started or stopped.+- Raised the `base` lower bound to 4.18, the first release with `Foreign.C.ConstPtr`.++### Added++- `logString` and `logStringL` take a `MessageSeverity`.+- `System.Tracy.Section`, `System.Tracy.Lock`, `System.Tracy.SharedLock` and `System.Tracy.SourceLocation`.+- `getTime`, `beginSamplingProfiling`, `endSamplingProfiling` and `System.Tracy.Memory.discard`.+- `enabled` tells whether the package was built with the `enable` flag.+- `System.Tracy.Gpu` for GPU contexts and zones.+  The GPU functions in `System.Tracy.FFI` go through a small C shim.+  The GHC FFI can't pass the structures the C API takes by value.+- `System.Tracy.Zone.withSourceLocation` runs a zone from a location made once with `newSourceLocation`.+- `frameImage` attaches a screenshot to a frame.+- `make DEBUG=1` builds everything in debug mode in `upstream/_build-debug`.++### Fixed++- `on_demand` builds now go through a small C shim.+  Since Tracy 0.14, the zone context in that mode has a size the GHC FFI can't pass by value.+- Zones now work on the non-threaded RTS without `zones_unsafe`.+  The bound-thread check only applies when the runtime has bound threads.+  A capture fails if zones from different Haskell threads overlap there.+- Text given to `message`, `messageC`, `appInfo`, `Zone.text` and `Zone.name` is now cut at 65534 bytes instead of tripping a Tracy assertion.+  The cut may split a multibyte character.+- `fiberLeave` now compiles with `fibers` and `enable` both set.+- `System.Tracy.FFI.Types` no longer goes stale after changing the `enable` or `on_demand` flags in an existing build directory.+- The Makefile's paths now match where it clones Tracy.+  The clone is pinned to the supported release.+- The Makefile now builds in release mode by default.+  CMake's Makefile generator ignored its `--config Release` and built the client library without optimizations.+- The Makefile now builds the client library without Tracy's crash handler.+  The handler treats `SIGPIPE` as a crash.+  GHC's threaded runtime sends that signal to cancel `interruptible` foreign calls.+  This aborted the program while a profiler was connected.+  Existing checkouts need `make clean && make all` to pick this up.+ ## 0.1.2.1 - 2025-11-02  - Fix `-enable` build without having libtracyclient installed.

@@ -6,8 +6,11 @@  ### Installing -You can install the prebuilt package from your distribution if it has one:+This version of the bindings targets Tracy 0.15.+Older releases have a different C API and will fail to link or misbehave. +You can install the prebuilt package from your distribution if it ships that release:+ ```sh sudo apt install libtracy-dev tracy-capture tracy-profiler ```@@ -26,12 +29,25 @@ ```sh make all # fetch and build stuff make test # run the example-_build/profiler/tracy-profiler & disown # launch the profiler GUI+upstream/_build/profiler/tracy-profiler & disown # launch the profiler GUI ``` +Everything is built in release mode.+Add `DEBUG=1` to any of those `make` commands for a debug build in `upstream/_build-debug`.+Debug builds keep Tracy's assertions on.+To use the debug library in your own project, point `extra-lib-dirs` at `upstream/_build-debug/library`.+ This way you can customize configuration. Make sure you update package flags to match. +The Makefile builds the library with `TRACY_NO_CRASH_HANDLER`.+That means the viewer won't get crash reports.+Tracy's crash handler treats `SIGPIPE` as a crash.+GHC's threaded runtime sends that signal to cancel `interruptible` foreign calls.+With the handler in place, `killThread` on a thread inside such a call aborts the program while a profiler is connected.+Any library built with the handler has this problem.+Check whether a distribution package was built with it.+ 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. @@ -49,9 +65,17 @@   tracy-profiler:     enable: true     # manual_lifetime: false+    # on_demand: false     # fibers: false ``` +To use on-demand mode, set the `on_demand` flag and link against a library built with `TRACY_ON_DEMAND`.+`make library-on-demand` builds one in `upstream/_build/library-on-demand`.+Point `extra-lib-dirs` there to use it.+The flag has to match the library.+The C API symbols don't encode that setting.+A mismatch links fine and then misbehaves at runtime.+ ## Instrumentation  Use the functions from `System.Tracy` and `System.Tracy.Zone` to collect data:@@ -63,12 +87,18 @@  module Main where +import Control.Monad (unless, when)+import System.Exit (die)+import System.IO (hPutStrLn, stderr) 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+  when Tracy.enabled do+    hPutStrLn stderr "Waiting for tracy-capture or tracy-profiler to connect on port 8086"+    isConnected <- Tracy.waitConnected 100000 (Just 30_000_000)+    unless isConnected $ die "Nothing connected within 30 seconds"   Tracy.withSrcLoc "main.nowhereInParticular" #f0fa do     Tracy.messageL "hi there"# -- static strings require no copying to be logged     mapM_ runFrame [0..600]@@ -84,6 +114,51 @@   Tracy.plotInt "digits"# digits ``` +Other modules cover more of the C API:++- `System.Tracy.Memory` reports allocations and frees.+- `System.Tracy.Section` marks high-level stretches of execution, such as a game level.+  Sections can overlap and aren't tied to a thread.+- `System.Tracy.Lock` and `System.Tracy.SharedLock` report waiting on and holding a lock.+  Give each one a location from `System.Tracy.SourceLocation.newSourceLocation`.+  The location stays allocated for the rest of the program because Tracy reads it later.+  Wait, obtain, shared release and mark events are recorded against the current OS thread.+  Use a bound thread to get them on the right timeline.+  Tracy 0.15's C API records a successful `SharedLock.tryAcquireShared` as an exclusive hold.+  The matching `releaseShared` doesn't end that hold.+- `System.Tracy.Zone.withSourceLocation` runs a zone from a location made once with `newSourceLocation`.+  `withSrcLoc` allocates a new location for every zone instead.+- `System.Tracy.Gpu` reports work done on the GPU.+  You issue the GPU timestamp queries yourself.+  Zones take an action that writes one and returns its query id.+  They call it at each end of the zone.+  Once the GPU has the results, pass each query id and its timestamp to `Gpu.time` in the order the queries were written.+  After that, the id can be reused.+  Tracy takes the first timestamp it gets for a zone as its start.+  `newContext` takes the length of a GPU tick in nanoseconds and a current GPU timestamp.+  Use `newCalibratedContext` instead for contexts that will get `calibration` events.+  The C API doesn't hand out context ids.+  Choose them from 0 to 255 yourself.+  Don't reuse ids of contexts made by C++ code in the same program.+  Tracy keeps one zone stack per context created through the C API.+  Zones in a context have to nest even across threads.+  With `on_demand`, a zone that starts before a viewer connects isn't recorded.+  Its timestamp actions aren't called.+  The module uses Tracy's serialized queue.+  It works from any thread.+  The unserialized GPU functions in `System.Tracy.FFI` are cheaper.+  They need all events for a context to come from one OS thread.+- `frameImage pixels width height lag flipped` attaches a screenshot to a frame.+  The pixels are RGBA.+  The width and height have to be multiples of 4.+  Tracy copies the pixels before `frameImage` returns.+  `lag` counts how many frames ago the image was taken.+  `flipped` means the rows go from bottom to top, as in OpenGL.++Call stack depths are only available through `System.Tracy.FFI` so far.++`beginSamplingProfiling` and `endSamplingProfiling` only take effect in a library built with `TRACY_SAMPLING_PROFILER_MANUAL_START`.+ ## Collecting and viewing  Start `tracy-capture` before running the test to avoid empty areas where nothing happens:@@ -92,7 +167,7 @@ tracy-capture -fo output.tracy & ``` -Run the code, then upload the collected data to [the viewer](https://tracy.nereid.pl/).+After running the code, upload the collected data to [the viewer](https://tracy.nereid.pl/).  You'll see something like this: @@ -100,8 +175,28 @@  > Are those are GC pauses we're looking at? 🤔 +### Sampling++On Linux, Tracy also samples call stacks and records context switches when `kernel.perf_event_paranoid` allows it.+Otherwise it logs a series of debug messages about failing to set up system tracing and carries on without it.++Sampled call stacks show up as ghost zones on threads that have no zones of their own.+In Haskell code, only the top frame of each sample can be trusted.+Tracy has the kernel build the rest by following frame pointers.+GHC uses the frame pointer register (`rbp` on x86-64) as its Haskell stack pointer instead.+The frames past the top one are leftovers from the Haskell stack.+Set `TRACY_NO_SAMPLING=1` in the program's environment to skip sampling while keeping context switches.+Ghost zones can also be hidden in the viewer.++Tracy names sampled frames from debug info or from the symbols an executable exports.+A GHC-built program has neither by default.+Its own frames show as `[unknown]`.+Add `-optl-rdynamic` to the executable's `ghc-options` to export them.+That names frames in the RTS, the Tracy client and Haskell code.+Haskell names come out in GHC's encoded form, such as `Main_main_info`.+ ## RTFM -You really should go read the official [manual](https://github.com/wolfpld/tracy/blob/master/manual/tracy.md).+You really should go read the official [manual](https://github.com/wolfpld/tracy/releases/download/v0.15.0/tracy.pdf).  Yes, BEFORE you run into corrupted memory, surprising grouppings, or otherwise botched profiling runs.

@@ -0,0 +1,124 @@+#include <stddef.h>+#include <stdint.h>++#include "TracyC.h"++void hs_tracy_emit_gpu_zone_begin(const struct ___tracy_source_location_data* srcloc, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_data data = { .srcloc = (uint64_t)(uintptr_t)srcloc, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin(data);+}++void hs_tracy_emit_gpu_zone_begin_callstack(const struct ___tracy_source_location_data* srcloc, int32_t depth, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_callstack_data data = { .srcloc = (uint64_t)(uintptr_t)srcloc, .depth = depth, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_callstack(data);+}++void hs_tracy_emit_gpu_zone_begin_alloc(uint64_t srcloc, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_data data = { .srcloc = srcloc, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_alloc(data);+}++void hs_tracy_emit_gpu_zone_begin_alloc_callstack(uint64_t srcloc, int32_t depth, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_callstack_data data = { .srcloc = srcloc, .depth = depth, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_alloc_callstack(data);+}++void hs_tracy_emit_gpu_zone_end(uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_end_data data = { .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_end(data);+}++void hs_tracy_emit_gpu_time(int64_t gpuTime, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_time_data data = { .gpuTime = gpuTime, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_time(data);+}++void hs_tracy_emit_gpu_new_context(int64_t gpuTime, float period, uint8_t context, uint8_t flags, uint8_t type)+{+    struct ___tracy_gpu_new_context_data data = { .gpuTime = gpuTime, .period = period, .context = context, .flags = flags, .type = type };+    ___tracy_emit_gpu_new_context(data);+}++void hs_tracy_emit_gpu_context_name(uint8_t context, const char* name, uint16_t len)+{+    struct ___tracy_gpu_context_name_data data = { .context = context, .name = name, .len = len };+    ___tracy_emit_gpu_context_name(data);+}++void hs_tracy_emit_gpu_calibration(int64_t gpuTime, int64_t cpuDelta, uint8_t context)+{+    struct ___tracy_gpu_calibration_data data = { .gpuTime = gpuTime, .cpuDelta = cpuDelta, .context = context };+    ___tracy_emit_gpu_calibration(data);+}++void hs_tracy_emit_gpu_time_sync(int64_t gpuTime, uint8_t context)+{+    struct ___tracy_gpu_time_sync_data data = { .gpuTime = gpuTime, .context = context };+    ___tracy_emit_gpu_time_sync(data);+}++void hs_tracy_emit_gpu_zone_begin_serial(const struct ___tracy_source_location_data* srcloc, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_data data = { .srcloc = (uint64_t)(uintptr_t)srcloc, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_serial(data);+}++void hs_tracy_emit_gpu_zone_begin_callstack_serial(const struct ___tracy_source_location_data* srcloc, int32_t depth, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_callstack_data data = { .srcloc = (uint64_t)(uintptr_t)srcloc, .depth = depth, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_callstack_serial(data);+}++void hs_tracy_emit_gpu_zone_begin_alloc_serial(uint64_t srcloc, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_data data = { .srcloc = srcloc, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_alloc_serial(data);+}++void hs_tracy_emit_gpu_zone_begin_alloc_callstack_serial(uint64_t srcloc, int32_t depth, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_begin_callstack_data data = { .srcloc = srcloc, .depth = depth, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_begin_alloc_callstack_serial(data);+}++void hs_tracy_emit_gpu_zone_end_serial(uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_zone_end_data data = { .queryId = queryId, .context = context };+    ___tracy_emit_gpu_zone_end_serial(data);+}++void hs_tracy_emit_gpu_time_serial(int64_t gpuTime, uint16_t queryId, uint8_t context)+{+    struct ___tracy_gpu_time_data data = { .gpuTime = gpuTime, .queryId = queryId, .context = context };+    ___tracy_emit_gpu_time_serial(data);+}++void hs_tracy_emit_gpu_new_context_serial(int64_t gpuTime, float period, uint8_t context, uint8_t flags, uint8_t type)+{+    struct ___tracy_gpu_new_context_data data = { .gpuTime = gpuTime, .period = period, .context = context, .flags = flags, .type = type };+    ___tracy_emit_gpu_new_context_serial(data);+}++void hs_tracy_emit_gpu_context_name_serial(uint8_t context, const char* name, uint16_t len)+{+    struct ___tracy_gpu_context_name_data data = { .context = context, .name = name, .len = len };+    ___tracy_emit_gpu_context_name_serial(data);+}++void hs_tracy_emit_gpu_calibration_serial(int64_t gpuTime, int64_t cpuDelta, uint8_t context)+{+    struct ___tracy_gpu_calibration_data data = { .gpuTime = gpuTime, .cpuDelta = cpuDelta, .context = context };+    ___tracy_emit_gpu_calibration_serial(data);+}++void hs_tracy_emit_gpu_time_sync_serial(int64_t gpuTime, uint8_t context)+{+    struct ___tracy_gpu_time_sync_data data = { .gpuTime = gpuTime, .context = context };+    ___tracy_emit_gpu_time_sync_serial(data);+}

@@ -0,0 +1,14 @@+#include <stddef.h>+#include <stdint.h>++#include "TracyC.h"++#define POINTER_BYTES sizeof(void*)++_Static_assert(offsetof(struct ___tracy_source_location_data, name) == 0, "SourceLocationData name offset");+_Static_assert(offsetof(struct ___tracy_source_location_data, function) == POINTER_BYTES, "SourceLocationData function offset");+_Static_assert(offsetof(struct ___tracy_source_location_data, file) == 2 * POINTER_BYTES, "SourceLocationData file offset");+_Static_assert(offsetof(struct ___tracy_source_location_data, line) == 3 * POINTER_BYTES, "SourceLocationData line offset");+_Static_assert(offsetof(struct ___tracy_source_location_data, color) == 3 * POINTER_BYTES + 4, "SourceLocationData color offset");+_Static_assert(sizeof(struct ___tracy_source_location_data) == 3 * POINTER_BYTES + 8, "SourceLocationData size");+_Static_assert(_Alignof(struct ___tracy_source_location_data) == _Alignof(void*), "SourceLocationData alignment");

@@ -0,0 +1,14 @@+#include <stddef.h>+#include <stdint.h>++#include "TracyC.h"++uint32_t hs_tracy_section_enter(uint16_t category, const char* text, size_t size)+{+    return ___tracy_section_enter(category, "%.*s", (int)size, text ? text : "");+}++void hs_tracy_section_setup(uint16_t category, const char* text, size_t size)+{+    ___tracy_section_setup(category, "%.*s", (int)size, text ? text : "");+}

@@ -0,0 +1,64 @@+#include <stddef.h>+#include <stdint.h>++#include "TracyC.h"++static void pack(TracyCZoneCtx ctx, uint64_t* out)+{+    out[0] = (uint64_t)ctx.id | ((uint64_t)(uint32_t)ctx.active << 32);+    out[1] = ctx.connectionId;+}++static TracyCZoneCtx unpack(uint64_t idAndActive, uint64_t connectionId)+{+    TracyCZoneCtx ctx;+    ctx.id = (uint32_t)idAndActive;+    ctx.active = (int32_t)(idAndActive >> 32);+    ctx.connectionId = connectionId;+    return ctx;+}++void hs_tracy_emit_zone_begin(const struct ___tracy_source_location_data* srcloc, int32_t active, uint64_t* out)+{+    pack(___tracy_emit_zone_begin(srcloc, active), out);+}++void hs_tracy_emit_zone_begin_callstack(const struct ___tracy_source_location_data* srcloc, int32_t depth, int32_t active, uint64_t* out)+{+    pack(___tracy_emit_zone_begin_callstack(srcloc, depth, active), out);+}++void hs_tracy_emit_zone_begin_alloc(uint64_t srcloc, int32_t active, uint64_t* out)+{+    pack(___tracy_emit_zone_begin_alloc(srcloc, active), out);+}++void hs_tracy_emit_zone_begin_alloc_callstack(uint64_t srcloc, int32_t depth, int32_t active, uint64_t* out)+{+    pack(___tracy_emit_zone_begin_alloc_callstack(srcloc, depth, active), out);+}++void hs_tracy_emit_zone_end(uint64_t idAndActive, uint64_t connectionId)+{+    ___tracy_emit_zone_end(unpack(idAndActive, connectionId));+}++void hs_tracy_emit_zone_text(uint64_t idAndActive, uint64_t connectionId, const char* txt, size_t size)+{+    ___tracy_emit_zone_text(unpack(idAndActive, connectionId), txt, size);+}++void hs_tracy_emit_zone_name(uint64_t idAndActive, uint64_t connectionId, const char* txt, size_t size)+{+    ___tracy_emit_zone_name(unpack(idAndActive, connectionId), txt, size);+}++void hs_tracy_emit_zone_color(uint64_t idAndActive, uint64_t connectionId, uint32_t color)+{+    ___tracy_emit_zone_color(unpack(idAndActive, connectionId), color);+}++void hs_tracy_emit_zone_value(uint64_t idAndActive, uint64_t connectionId, uint64_t value)+{+    ___tracy_emit_zone_value(unpack(idAndActive, connectionId), value);+}

@@ -2,26 +2,44 @@ {-# LANGUAGE MagicHash #-}  module System.Tracy-  ( withProfiler+  ( -- * 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@@ -30,30 +48,34 @@   , 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 GHC.Exts (Addr#)+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 (nullPtr)+import Foreign (castPtr, fromBool, nullPtr) import Foreign.C.ConstPtr (ConstPtr(..))-import GHC.Exts(Ptr(..)) import System.Timeout (timeout) import System.Tracy.FFI qualified as FFI+import System.Tracy.FFI.Types (clampTextBytes) #endif -import System.Tracy.FFI.Types (Color, PlotFormat(..))+import System.Tracy.FFI.Types (Color, MessageSeverity(..), PlotFormat(..)) import System.Tracy.Zone qualified as Zone  #if defined(TRACY_ENABLE) && defined(TRACY_MANUAL_LIFETIME)@@ -74,6 +96,13 @@ withProfiler = id #endif +enabled :: Bool+#if defined(TRACY_ENABLE)+enabled = True+#else+enabled = False+#endif+ {- | Check whether the profiler is connected. -} connected :: IO Bool@@ -155,45 +184,70 @@ frameMarkEnd _name = pure () #endif --- TODO: nicer wrapper for emitFrameImage+{-# 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)-message txt = liftIO $+logString severity color txt = liftIO $   Text.withCStringLen txt \(txtPtr, txtSz) ->-    FFI.emitMessage (ConstPtr txtPtr) (fromIntegral txtSz) 0+    FFI.emitLogString (fromIntegral $ fromEnum severity) color 0 (clampTextBytes txtSz) (ConstPtr txtPtr) #else-message _txt = pure ()+logString _severity _color _txt = pure () #endif -{-# INLINE messageC #-}-messageC :: MonadIO m => Color -> Text -> m ()+{-# INLINE logStringL #-}+logStringL :: MonadIO m => MessageSeverity -> Color -> Addr# -> m () #if defined(TRACY_ENABLE)-messageC color txt = liftIO $-  Text.withCStringLen txt \(txtPtr, txtSz) ->-    FFI.emitMessageC (ConstPtr txtPtr) (fromIntegral txtSz) color 0+logStringL severity color txt = liftIO $+  FFI.emitLogStringL (fromIntegral $ fromEnum severity) color 0 (ConstPtr (Ptr txt)) #else-messageC _color _txt = pure ()+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 -{-# INLINE messageL #-}-messageL :: MonadIO m => Addr# -> m ()+beginSamplingProfiling :: MonadIO m => m Bool #if defined(TRACY_ENABLE)-messageL txt = liftIO $-  FFI.emitMessageL (ConstPtr (Ptr txt)) 0+beginSamplingProfiling = liftIO $ (/= 0) <$> FFI.beginSamplingProfiling #else-messageL _txt = pure ()+beginSamplingProfiling = pure False #endif -{-# INLINE messageLC #-}-messageLC :: MonadIO m => Color -> Addr# -> m ()+endSamplingProfiling :: MonadIO m => m () #if defined(TRACY_ENABLE)-messageLC color txt = liftIO $-  FFI.emitMessageLC (ConstPtr (Ptr txt)) color 0+endSamplingProfiling = liftIO FFI.endSamplingProfiling #else-messageLC _color _txt = pure ()+endSamplingProfiling = pure () #endif  {-# INLINE plot #-}@@ -260,7 +314,7 @@ #if defined(TRACY_ENABLE) appInfo txt = liftIO $   Text.withCStringLen txt \(txtPtr, txtSz) ->-    FFI.emitMessageAppinfo (ConstPtr txtPtr) (fromIntegral txtSz)+    FFI.emitMessageAppinfo (ConstPtr txtPtr) (clampTextBytes txtSz) #else appInfo _txt = pure () #endif@@ -278,8 +332,7 @@ {-# INLINE fiberLeave #-} fiberLeave :: MonadIO m => m () #if defined(TRACY_ENABLE)-fiberLeave name val = liftIO $-  FFI.fiberLeave+fiberLeave = liftIO FFI.fiberLeave #else fiberLeave = pure () #endif

@@ -1,13 +1,154 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} -module System.Tracy.FFI where+module System.Tracy.FFI+  ( -- * Profiler+    profilerStarted+#ifdef TRACY_MANUAL_LIFETIME+  , startupProfiler+  , shutdownProfiler+#endif+  , connected +    -- * Threads+  , setThreadName++    -- * Source locations+  , allocSrcloc+  , allocSrclocName++    -- * Zones+  , emitZoneBegin+  , emitZoneBeginCallstack+  , emitZoneBeginAlloc+  , emitZoneBeginAllocCallstack+  , emitZoneEnd+  , emitZoneText+  , emitZoneName+  , emitZoneColor+  , emitZoneValue+#ifdef TRACY_ON_DEMAND++    -- * On-demand zone shim+  , receiveZoneCtx+  , hsEmitZoneBegin+  , hsEmitZoneBeginCallstack+  , hsEmitZoneBeginAlloc+  , hsEmitZoneBeginAllocCallstack+  , hsEmitZoneEnd+  , hsEmitZoneText+  , hsEmitZoneName+  , hsEmitZoneColor+  , hsEmitZoneValue+#endif++    -- * GPU+  , emitGpuZoneBegin+  , emitGpuZoneBeginCallstack+  , emitGpuZoneBeginAlloc+  , emitGpuZoneBeginAllocCallstack+  , emitGpuZoneEnd+  , emitGpuTime+  , emitGpuNewContext+  , emitGpuContextName+  , emitGpuCalibration+  , emitGpuTimeSync++    -- * Serialized GPU+  , emitGpuZoneBeginSerial+  , emitGpuZoneBeginCallstackSerial+  , emitGpuZoneBeginAllocSerial+  , emitGpuZoneBeginAllocCallstackSerial+  , emitGpuZoneEndSerial+  , emitGpuTimeSerial+  , emitGpuNewContextSerial+  , emitGpuContextNameSerial+  , emitGpuCalibrationSerial+  , emitGpuTimeSyncSerial++    -- * Memory+  , emitMemoryAlloc+  , emitMemoryAllocCallstack+  , emitMemoryFree+  , emitMemoryFreeCallstack+  , emitMemoryAllocNamed+  , emitMemoryAllocCallstackNamed+  , emitMemoryFreeNamed+  , emitMemoryFreeCallstackNamed+  , emitMemoryDiscard+  , emitMemoryDiscardCallstack++    -- * Messages+  , emitLogString+  , emitLogStringL+  , emitMessageAppinfo++    -- * Frames+  , emitFrameMark+  , emitFrameMarkStart+  , emitFrameMarkEnd+  , emitFrameImage++    -- * Plots+  , emitPlot+  , emitPlotFloat+  , emitPlotInt+  , emitPlotConfig++    -- * Locks+  , announceLockableCtx+  , terminateLockableCtx+  , beforeLockLockableCtx+  , afterLockLockableCtx+  , beforeUnlockLockableCtx+  , afterTryLockLockableCtx+  , markLockableCtx+  , customNameLockableCtx++    -- * Shared locks+  , announceSharedLockableCtx+  , terminateSharedLockableCtx+  , beforeLockSharedLockableCtx+  , afterLockSharedLockableCtx+  , beforeUnlockSharedLockableCtx+  , afterTryLockSharedLockableCtx+  , beforeLockSharedSharedLockableCtx+  , afterLockSharedSharedLockableCtx+  , beforeUnlockSharedSharedLockableCtx+  , afterTryLockSharedSharedLockableCtx+  , markSharedLockableCtx+  , customNameSharedLockableCtx++    -- * Sections+  , sectionEnter+  , sectionLeave+  , sectionSetup++    -- * Time+  , getTime++    -- * Sampling profiler+  , beginSamplingProfiling+  , endSamplingProfiling++#ifdef TRACY_FIBERS+    -- * Fibers+  , fiberEnter+  , fiberLeave+#endif+  ) where+ import Data.Int import Data.Word import Foreign.C import Foreign.C.ConstPtr (ConstPtr(..)) +#ifdef TRACY_ON_DEMAND+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peekElemOff)+#endif+ import System.Tracy.FFI.Types  ----------------------------------------------------------------@@ -30,10 +171,10 @@  foreign import ccall unsafe "___tracy_profiler_started"   profilerStarted-    :: Int+    :: IO Int32 #else-profilerStarted :: Int-profilerStarted = 1+profilerStarted :: IO Int32+profilerStarted = pure 1 #endif  ----------------------------------------------------------------@@ -62,6 +203,76 @@  ---------------------------------------------------------------- +#ifdef TRACY_ON_DEMAND+receiveZoneCtx :: (Ptr Word64 -> IO ()) -> IO TracyCZoneCtx+receiveZoneCtx begin =+  allocaArray 2 \out -> do+    begin out+    TracyCZoneCtx <$> peekElemOff out 0 <*> peekElemOff out 1++foreign import ccall unsafe "hs_tracy_emit_zone_begin"+  hsEmitZoneBegin :: ConstPtr SourceLocationData -> Int -> Ptr Word64 -> IO ()++emitZoneBegin :: ConstPtr SourceLocationData -> Int -> IO TracyCZoneCtx+emitZoneBegin srcloc active =+  receiveZoneCtx (hsEmitZoneBegin srcloc active)++foreign import ccall unsafe "hs_tracy_emit_zone_begin_callstack"+  hsEmitZoneBeginCallstack :: ConstPtr SourceLocationData -> Int -> Int -> Ptr Word64 -> IO ()++emitZoneBeginCallstack :: ConstPtr SourceLocationData -> Int -> Int -> IO TracyCZoneCtx+emitZoneBeginCallstack srcloc depth active =+  receiveZoneCtx (hsEmitZoneBeginCallstack srcloc depth active)++foreign import ccall unsafe "hs_tracy_emit_zone_begin_alloc"+  hsEmitZoneBeginAlloc :: SrcLoc -> Int -> Ptr Word64 -> IO ()++emitZoneBeginAlloc :: SrcLoc -> Int -> IO TracyCZoneCtx+emitZoneBeginAlloc srcloc active =+  receiveZoneCtx (hsEmitZoneBeginAlloc srcloc active)++foreign import ccall unsafe "hs_tracy_emit_zone_begin_alloc_callstack"+  hsEmitZoneBeginAllocCallstack :: SrcLoc -> Int -> Int -> Ptr Word64 -> IO ()++emitZoneBeginAllocCallstack :: SrcLoc -> Int -> Int -> IO TracyCZoneCtx+emitZoneBeginAllocCallstack srcloc depth active =+  receiveZoneCtx (hsEmitZoneBeginAllocCallstack srcloc depth active)++foreign import ccall unsafe "hs_tracy_emit_zone_end"+  hsEmitZoneEnd :: Word64 -> Word64 -> IO ()++emitZoneEnd :: TracyCZoneCtx -> IO ()+emitZoneEnd TracyCZoneCtx{..} =+  hsEmitZoneEnd idAndActive connectionId++foreign import ccall unsafe "hs_tracy_emit_zone_text"+  hsEmitZoneText :: Word64 -> Word64 -> ConstPtr CChar -> CSize -> IO ()++emitZoneText :: TracyCZoneCtx -> ConstPtr CChar -> CSize -> IO ()+emitZoneText TracyCZoneCtx{..} =+  hsEmitZoneText idAndActive connectionId++foreign import ccall unsafe "hs_tracy_emit_zone_name"+  hsEmitZoneName :: Word64 -> Word64 -> ConstPtr CChar -> CSize -> IO ()++emitZoneName :: TracyCZoneCtx -> ConstPtr CChar -> CSize -> IO ()+emitZoneName TracyCZoneCtx{..} =+  hsEmitZoneName idAndActive connectionId++foreign import ccall unsafe "hs_tracy_emit_zone_color"+  hsEmitZoneColor :: Word64 -> Word64 -> Color -> IO ()++emitZoneColor :: TracyCZoneCtx -> Color -> IO ()+emitZoneColor TracyCZoneCtx{..} =+  hsEmitZoneColor idAndActive connectionId++foreign import ccall unsafe "hs_tracy_emit_zone_value"+  hsEmitZoneValue :: Word64 -> Word64 -> Word64 -> IO ()++emitZoneValue :: TracyCZoneCtx -> Word64 -> IO ()+emitZoneValue TracyCZoneCtx{..} =+  hsEmitZoneValue idAndActive connectionId+#else foreign import ccall unsafe "___tracy_emit_zone_begin"   emitZoneBegin     :: ConstPtr SourceLocationData -- ^ srcloc@@ -118,38 +329,77 @@     :: TracyCZoneCtx     -> Word64     -> IO ()+#endif  ---------------------------------------------------------------- -{--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 );+foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin"+  emitGpuZoneBegin :: ConstPtr SourceLocationData -> Word16 -> Word8 -> IO () -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 "hs_tracy_emit_gpu_zone_begin_callstack"+  emitGpuZoneBeginCallstack :: ConstPtr SourceLocationData -> Int32 -> Word16 -> Word8 -> IO () +foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_alloc"+  emitGpuZoneBeginAlloc :: SrcLoc -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_alloc_callstack"+  emitGpuZoneBeginAllocCallstack :: SrcLoc -> Int32 -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_end"+  emitGpuZoneEnd :: Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_time"+  emitGpuTime :: Int64 -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_new_context"+  emitGpuNewContext :: Int64 -> Float -> Word8 -> Word8 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_context_name"+  emitGpuContextName :: Word8 -> ConstPtr CChar -> Word16 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_calibration"+  emitGpuCalibration :: Int64 -> Int64 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_time_sync"+  emitGpuTimeSync :: Int64 -> Word8 -> IO ()+ ---------------------------------------------------------------- +foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_serial"+  emitGpuZoneBeginSerial :: ConstPtr SourceLocationData -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_callstack_serial"+  emitGpuZoneBeginCallstackSerial :: ConstPtr SourceLocationData -> Int32 -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_alloc_serial"+  emitGpuZoneBeginAllocSerial :: SrcLoc -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_begin_alloc_callstack_serial"+  emitGpuZoneBeginAllocCallstackSerial :: SrcLoc -> Int32 -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_zone_end_serial"+  emitGpuZoneEndSerial :: Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_time_serial"+  emitGpuTimeSerial :: Int64 -> Word16 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_new_context_serial"+  emitGpuNewContextSerial :: Int64 -> Float -> Word8 -> Word8 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_context_name_serial"+  emitGpuContextNameSerial :: Word8 -> ConstPtr CChar -> Word16 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_calibration_serial"+  emitGpuCalibrationSerial :: Int64 -> Int64 -> Word8 -> IO ()++foreign import ccall unsafe "hs_tracy_emit_gpu_time_sync_serial"+  emitGpuTimeSyncSerial :: Int64 -> Word8 -> IO ()++----------------------------------------------------------------+ foreign import ccall unsafe "___tracy_connected"   connected-    :: IO Int+    :: IO Int32  ---------------------------------------------------------------- @@ -157,7 +407,6 @@   emitMemoryAlloc     :: ConstPtr () -- ^ ptr     -> CSize       -- ^ size-    -> CInt        -- ^ secure     -> IO ()  foreign import ccall unsafe "___tracy_emit_memory_alloc_callstack"@@ -165,27 +414,23 @@     :: 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 () @@ -194,14 +439,12 @@     :: 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 () @@ -209,38 +452,32 @@   emitMemoryFreeCallstackNamed     :: ConstPtr ()    -- ^ ptr     -> CInt           -- ^ depth-    -> CInt           -- ^ secure     -> ConstPtr CChar -- ^ name     -> IO () -----------------------------------------------------------------+foreign import ccall unsafe "___tracy_emit_memory_discard"+  emitMemoryDiscard :: ConstPtr CChar -> IO () -foreign import ccall unsafe "___tracy_emit_message"-  emitMessage-    :: ConstPtr CChar -- ^ txt-    -> CSize          -- ^ size-    -> CInt           -- ^ callstack-    -> IO ()+foreign import ccall unsafe "___tracy_emit_memory_discard_callstack"+  emitMemoryDiscardCallstack :: ConstPtr CChar -> CInt -> 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+foreign import ccall unsafe "___tracy_emit_logString"+  emitLogString+    :: Int8+    -> Color+    -> CInt+    -> CSize+    -> ConstPtr CChar     -> IO () -foreign import ccall unsafe "___tracy_emit_messageLC"-  emitMessageLC-    :: ConstPtr CChar -- ^ txt-    -> Color          -- ^ color-    -> CInt           -- ^ callstack+foreign import ccall unsafe "___tracy_emit_logStringL"+  emitLogStringL+    :: Int8+    -> Color+    -> CInt+    -> ConstPtr CChar     -> IO ()  ----------------------------------------------------------------@@ -307,16 +544,89 @@  ---------------------------------------------------------------- -{--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 );--}+foreign import ccall unsafe "___tracy_announce_lockable_ctx"+  announceLockableCtx :: ConstPtr SourceLocationData -> IO TracyCLockCtx++foreign import ccall unsafe "___tracy_terminate_lockable_ctx"+  terminateLockableCtx :: TracyCLockCtx -> IO ()++foreign import ccall unsafe "___tracy_before_lock_lockable_ctx"+  beforeLockLockableCtx :: TracyCLockCtx -> IO Int32++foreign import ccall unsafe "___tracy_after_lock_lockable_ctx"+  afterLockLockableCtx :: TracyCLockCtx -> IO ()++foreign import ccall unsafe "___tracy_before_unlock_lockable_ctx"+  beforeUnlockLockableCtx :: TracyCLockCtx -> IO ()++foreign import ccall unsafe "___tracy_after_try_lock_lockable_ctx"+  afterTryLockLockableCtx :: TracyCLockCtx -> Int32 -> IO ()++foreign import ccall unsafe "___tracy_mark_lockable_ctx"+  markLockableCtx :: TracyCLockCtx -> ConstPtr SourceLocationData -> IO ()++foreign import ccall unsafe "___tracy_custom_name_lockable_ctx"+  customNameLockableCtx :: TracyCLockCtx -> ConstPtr CChar -> CSize -> IO ()++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_announce_shared_lockable_ctx"+  announceSharedLockableCtx :: ConstPtr SourceLocationData -> IO TracyCSharedLockCtx++foreign import ccall unsafe "___tracy_terminate_shared_lockable_ctx"+  terminateSharedLockableCtx :: TracyCSharedLockCtx -> IO ()++foreign import ccall unsafe "___tracy_before_lock_shared_lockable_ctx"+  beforeLockSharedLockableCtx :: TracyCSharedLockCtx -> IO Int32++foreign import ccall unsafe "___tracy_after_lock_shared_lockable_ctx"+  afterLockSharedLockableCtx :: TracyCSharedLockCtx -> IO ()++foreign import ccall unsafe "___tracy_before_unlock_shared_lockable_ctx"+  beforeUnlockSharedLockableCtx :: TracyCSharedLockCtx -> IO ()++foreign import ccall unsafe "___tracy_after_try_lock_shared_lockable_ctx"+  afterTryLockSharedLockableCtx :: TracyCSharedLockCtx -> Int32 -> IO ()++foreign import ccall unsafe "___tracy_before_lock_shared_shared_lockable_ctx"+  beforeLockSharedSharedLockableCtx :: TracyCSharedLockCtx -> IO Int32++foreign import ccall unsafe "___tracy_after_lock_shared_shared_lockable_ctx"+  afterLockSharedSharedLockableCtx :: TracyCSharedLockCtx -> IO ()++foreign import ccall unsafe "___tracy_before_unlock_shared_shared_lockable_ctx"+  beforeUnlockSharedSharedLockableCtx :: TracyCSharedLockCtx -> IO ()++foreign import ccall unsafe "___tracy_after_try_lock_shared_shared_lockable_ctx"+  afterTryLockSharedSharedLockableCtx :: TracyCSharedLockCtx -> Int32 -> IO ()++foreign import ccall unsafe "___tracy_mark_shared_lockable_ctx"+  markSharedLockableCtx :: TracyCSharedLockCtx -> ConstPtr SourceLocationData -> IO ()++foreign import ccall unsafe "___tracy_custom_name_shared_lockable_ctx"+  customNameSharedLockableCtx :: TracyCSharedLockCtx -> ConstPtr CChar -> CSize -> IO ()++----------------------------------------------------------------++foreign import ccall unsafe "hs_tracy_section_enter"+  sectionEnter :: Word16 -> ConstPtr CChar -> CSize -> IO Word32++foreign import ccall unsafe "___tracy_section_leave"+  sectionLeave :: Word32 -> IO ()++foreign import ccall unsafe "hs_tracy_section_setup"+  sectionSetup :: Word16 -> ConstPtr CChar -> CSize -> IO ()++----------------------------------------------------------------++foreign import ccall unsafe "___tracy_get_time"+  getTime :: IO Int64++foreign import ccall safe "___tracy_begin_sampling_profiling"+  beginSamplingProfiling :: IO CInt++foreign import ccall safe "___tracy_end_sampling_profiling"+  endSamplingProfiling :: IO ()  ---------------------------------------------------------------- 

@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}++module System.Tracy.FFI.Types+  ( -- * Colors+    Color(..)++    -- * Source locations+  , SrcLoc(..)+  , SourceLocationData(..)+  , pointerBytes++    -- * Contexts+  , TracyCZoneCtx(..)+  , nullTracyCZoneCtx+  , TracyCLockCtx(..)+  , TracyCSharedLockCtx(..)++    -- * Plots+  , PlotFormat(..)++    -- * Messages+  , MessageSeverity(..)++    -- * GPU+  , GpuContextType(..)+  , gpuContextTypeCode++    -- * Text limits+  , maxTextBytes+  , clampTextBytes+  ) where++import Data.Word+import Foreign+import Foreign.C++import WebColor.Labels+import GHC.OverloadedLabels++{- | 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)++instance IsWebColorAlpha s => IsLabel s Color where+  fromLabel = webColorAlpha @s \r g b a ->+    Color $+      shiftL (fromIntegral a) 24 .|.+      shiftL (fromIntegral r) 16 .|.+      shiftL (fromIntegral g)  8 .|.+      fromIntegral b++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    :: Color+  }++pointerBytes :: Int+pointerBytes = sizeOf (nullPtr :: Ptr ())++instance Storable SourceLocationData where+  sizeOf (~_undef) = 3 * pointerBytes + 8++  alignment (~_undef) = pointerBytes++  peek ptr = do+    name     <- peekByteOff ptr 0+    function <- peekByteOff ptr pointerBytes+    file     <- peekByteOff ptr (2 * pointerBytes)+    line     <- peekByteOff ptr (3 * pointerBytes)+    color    <- peekByteOff ptr (3 * pointerBytes + 4)+    pure SourceLocationData{..}++  poke ptr SourceLocationData{..} = do+    pokeByteOff ptr 0 name+    pokeByteOff ptr pointerBytes function+    pokeByteOff ptr (2 * pointerBytes) file+    pokeByteOff ptr (3 * pointerBytes) line+    pokeByteOff ptr (3 * pointerBytes + 4) color++#ifdef TRACY_ON_DEMAND+data TracyCZoneCtx = TracyCZoneCtx+  { idAndActive  :: Word64+  , connectionId :: Word64+  }+  deriving (Eq, Ord, Show)++nullTracyCZoneCtx :: TracyCZoneCtx+nullTracyCZoneCtx = TracyCZoneCtx 0 0+#else+newtype TracyCZoneCtx = TracyCZoneCtx (Ptr TracyCZoneCtx)+  deriving (Show)+  deriving newtype (Eq, Ord, Storable)++nullTracyCZoneCtx :: TracyCZoneCtx+nullTracyCZoneCtx = TracyCZoneCtx nullPtr+#endif++newtype TracyCLockCtx = TracyCLockCtx (Ptr TracyCLockCtx)+  deriving (Show)+  deriving newtype (Eq, Ord, Storable)++newtype TracyCSharedLockCtx = TracyCSharedLockCtx (Ptr TracyCSharedLockCtx)+  deriving (Show)+  deriving newtype (Eq, Ord, Storable)++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)++data MessageSeverity+  = MessageSeverityTrace+  | MessageSeverityDebug+  | MessageSeverityInfo+  | MessageSeverityWarning+  | MessageSeverityError+  | MessageSeverityFatal+  deriving (Eq, Ord, Show, Enum, Bounded)++data GpuContextType+  = GpuContextTypeOpenGl+  | GpuContextTypeVulkan+  | GpuContextTypeOpenCL+  | GpuContextTypeDirect3D12+  | GpuContextTypeDirect3D11+  | GpuContextTypeMetal+  | GpuContextTypeCustom+  | GpuContextTypeCUDA+  | GpuContextTypeRocprof+  | GpuContextTypeWebGPU+  deriving (Eq, Ord, Show, Bounded)++gpuContextTypeCode :: GpuContextType -> Word8+gpuContextTypeCode = \case+  GpuContextTypeOpenGl -> 1+  GpuContextTypeVulkan -> 2+  GpuContextTypeOpenCL -> 3+  GpuContextTypeDirect3D12 -> 4+  GpuContextTypeDirect3D11 -> 5+  GpuContextTypeMetal -> 6+  GpuContextTypeCustom -> 7+  GpuContextTypeCUDA -> 8+  GpuContextTypeRocprof -> 9+  GpuContextTypeWebGPU -> 10++maxTextBytes :: Int+maxTextBytes = 65534++clampTextBytes :: Int -> CSize+clampTextBytes = fromIntegral . min maxTextBytes

@@ -1,76 +0,0 @@-module System.Tracy.FFI.Types where--import Data.Word-import Foreign-import Foreign.C--import WebColor.Labels-import GHC.OverloadedLabels--{- | 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)--instance IsWebColorAlpha s => IsLabel s Color where-  fromLabel = webColorAlpha @s \r g b a ->-    Color $-      shiftL (fromIntegral a) 24 .|.-      shiftL (fromIntegral r) 16 .|.-      shiftL (fromIntegral g)  8 .|.-      fromIntegral b--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    :: Color-  }--#ifdef TRACY_ENABLE-#include "TracyC.h"--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--#endif--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)

@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}++module System.Tracy.Gpu+  ( -- * Contexts+    Context(..)+  , GpuContextType(..)+  , newContext+  , newCalibratedContext+  , contextName++    -- * Scoped zones+  , withSrcLoc+  , withSourceLocation++    -- * Manual zones+  , Zone(..)+  , beginSrcLoc+  , beginSourceLocation+  , end++    -- * Timestamps+  , time+  , calibration+  , timeSync+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Word (Word8, Word16)++#ifdef TRACY_ENABLE+import Control.Exception (bracket)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.ByteString.Char8 qualified as ByteString+import Data.Text.Foreign qualified as Text+import Foreign.C.ConstPtr (ConstPtr(..))+import GHC.Stack (HasCallStack, SrcLoc(..), callStack, getCallStack, withFrozenCallStack)++import System.Tracy.FFI qualified as FFI+import System.Tracy.FFI.Types (gpuContextTypeCode, maxTextBytes)+import System.Tracy.Zone qualified as Zone+#endif++import System.Tracy.FFI.Types (Color, GpuContextType(..))+import System.Tracy.SourceLocation (SourceLocation(..))++newtype Context = Context Word8+  deriving (Eq, Ord, Show)++newtype Zone = Zone (Maybe Context)+  deriving (Eq, Ord, Show)++uncalibratedFlags :: Word8+uncalibratedFlags = 0++calibratedFlags :: Word8+calibratedFlags = 1++{-# INLINE newContext #-}+newContext :: MonadIO m => Context -> GpuContextType -> Float -> Int64 -> m ()+newContext = emitNewContext uncalibratedFlags++{-# INLINE newCalibratedContext #-}+newCalibratedContext :: MonadIO m => Context -> GpuContextType -> Float -> Int64 -> m ()+newCalibratedContext = emitNewContext calibratedFlags++{-# INLINE emitNewContext #-}+emitNewContext :: MonadIO m => Word8 -> Context -> GpuContextType -> Float -> Int64 -> m ()+#ifdef TRACY_ENABLE+emitNewContext flags (Context contextId) contextType period gpuTime = liftIO $+  FFI.emitGpuNewContextSerial gpuTime period contextId flags (gpuContextTypeCode contextType)+#else+emitNewContext _flags _context _contextType _period _gpuTime = pure ()+#endif++{-# INLINE contextName #-}+contextName :: MonadIO m => Context -> Text -> m ()+#ifdef TRACY_ENABLE+contextName (Context contextId) txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.emitGpuContextNameSerial contextId (ConstPtr txtPtr) (fromIntegral $ min maxTextBytes txtSz)+#else+contextName _context _txt = pure ()+#endif++{-# INLINE withSrcLoc #-}+{-# INLINE withSourceLocation #-}+#ifdef TRACY_ENABLE+withSrcLoc+  :: (HasCallStack, MonadUnliftIO m)+  => Context+  -> ByteString+  -> Color+  -> m Word16+  -> m Word16+  -> m a+  -> m a+withSrcLoc context function col writeBeginTimestamp =+  withZone (withFrozenCallStack (beginSrcLoc context function col writeBeginTimestamp))++withSourceLocation+  :: MonadUnliftIO m+  => Context+  -> SourceLocation+  -> m Word16+  -> m Word16+  -> m a+  -> m a+withSourceLocation context location writeBeginTimestamp =+  withZone (beginSourceLocation context location writeBeginTimestamp)++{-# INLINE withZone #-}+withZone :: MonadUnliftIO m => m Zone -> m Word16 -> m a -> m a+withZone begin writeEndTimestamp action =+  withRunInIO \run ->+    bracket+      (run begin)+      (\zone -> run $ end zone writeEndTimestamp)+      (\_zone -> run action)+#else+withSrcLoc :: Context -> ByteString -> Color -> m Word16 -> m Word16 -> m a -> m a+withSrcLoc _context _function _col _writeBeginTimestamp _writeEndTimestamp action = action++withSourceLocation :: Context -> SourceLocation -> m Word16 -> m Word16 -> m a -> m a+withSourceLocation _context _location _writeBeginTimestamp _writeEndTimestamp action = action+#endif++{-# INLINE beginSrcLoc #-}+#ifdef TRACY_ENABLE+beginSrcLoc :: (HasCallStack, MonadIO m) => Context -> ByteString -> Color -> m Word16 -> m Zone+beginSrcLoc context@(Context contextId) function col writeTimestamp =+  case getCallStack callStack of+    (_called, SrcLoc{srcLocFile, srcLocStartLine}) : _callers ->+      beginWith context writeTimestamp \queryId -> do+        srcloc <-+          Zone.allocSrcloc+            (fromIntegral srcLocStartLine)+            (ByteString.pack srcLocFile)+            function+            Nothing+            col+        FFI.emitGpuZoneBeginAllocSerial srcloc queryId contextId+    [] ->+      error "beginSrcLoc ought to have HasCallStack in context"+#else+beginSrcLoc :: MonadIO m => Context -> ByteString -> Color -> m Word16 -> m Zone+beginSrcLoc _context _function _col _writeTimestamp = pure $ Zone Nothing+#endif++{-# INLINE beginSourceLocation #-}+beginSourceLocation :: MonadIO m => Context -> SourceLocation -> m Word16 -> m Zone+#ifdef TRACY_ENABLE+beginSourceLocation context@(Context contextId) (SourceLocation locationData) writeTimestamp =+  beginWith context writeTimestamp \queryId ->+    FFI.emitGpuZoneBeginSerial locationData queryId contextId+#else+beginSourceLocation _context _location _writeTimestamp = pure $ Zone Nothing+#endif++#ifdef TRACY_ENABLE+{-# INLINE beginWith #-}+beginWith :: MonadIO m => Context -> m Word16 -> (Word16 -> IO ()) -> m Zone+beginWith context writeTimestamp emitBegin = do+  recording <- liftIO isRecording+  if recording then do+    queryId <- writeTimestamp+    liftIO $ emitBegin queryId+    pure . Zone $ Just context+  else+    pure $ Zone Nothing++{-# INLINE isRecording #-}+isRecording :: IO Bool+#ifdef TRACY_ON_DEMAND+isRecording = (/= 0) <$> FFI.connected+#else+isRecording = pure True+#endif+#endif++{-# INLINE end #-}+end :: MonadIO m => Zone -> m Word16 -> m ()+#ifdef TRACY_ENABLE+end (Zone (Just (Context contextId))) writeTimestamp = do+  queryId <- writeTimestamp+  liftIO $ FFI.emitGpuZoneEndSerial queryId contextId+end (Zone Nothing) _writeTimestamp = pure ()+#else+end _zone _writeTimestamp = pure ()+#endif++{-# INLINE time #-}+time :: MonadIO m => Context -> Word16 -> Int64 -> m ()+#ifdef TRACY_ENABLE+time (Context contextId) queryId gpuTime = liftIO $+  FFI.emitGpuTimeSerial gpuTime queryId contextId+#else+time _context _queryId _gpuTime = pure ()+#endif++{-# INLINE calibration #-}+calibration :: MonadIO m => Context -> Int64 -> Int64 -> m ()+#ifdef TRACY_ENABLE+calibration (Context contextId) gpuTime cpuDelta = liftIO $+  FFI.emitGpuCalibrationSerial gpuTime cpuDelta contextId+#else+calibration _context _gpuTime _cpuDelta = pure ()+#endif++{-# INLINE timeSync #-}+timeSync :: MonadIO m => Context -> Int64 -> m ()+#ifdef TRACY_ENABLE+timeSync (Context contextId) gpuTime = liftIO $+  FFI.emitGpuTimeSyncSerial gpuTime contextId+#else+timeSync _context _gpuTime = pure ()+#endif

@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}++module System.Tracy.Lock+  ( -- * Lifetime+    Lock(..)+  , announce+  , terminate++    -- * Locking+  , acquire+  , tryAcquire+  , release++    -- * Annotations+  , mark+  , customName+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Text (Text)++#ifdef TRACY_ENABLE+import Control.Monad (when)+import Data.Text.Foreign qualified as Text+import Foreign.C.ConstPtr (ConstPtr(..))+import Foreign.Marshal.Utils (fromBool)++import System.Tracy.FFI qualified as FFI+#else+import Foreign.Ptr (nullPtr)+#endif++import System.Tracy.FFI.Types qualified as FFI+import System.Tracy.SourceLocation (SourceLocation(..))++newtype Lock = Lock FFI.TracyCLockCtx++{-# INLINE announce #-}+announce :: MonadIO m => SourceLocation -> m Lock+#ifdef TRACY_ENABLE+announce (SourceLocation location) = liftIO $ Lock <$> FFI.announceLockableCtx location+#else+announce _location = pure . Lock $ FFI.TracyCLockCtx nullPtr+#endif++{-# INLINE terminate #-}+terminate :: MonadIO m => Lock -> m ()+#ifdef TRACY_ENABLE+terminate (Lock ctx) = liftIO $ FFI.terminateLockableCtx ctx+#else+terminate _lock = pure ()+#endif++{-# INLINE acquire #-}+#ifdef TRACY_ENABLE+acquire :: MonadIO m => Lock -> m a -> m a+acquire (Lock ctx) takeLock = do+  waitRecorded <- liftIO $ FFI.beforeLockLockableCtx ctx+  result <- takeLock+  when (waitRecorded /= 0) . liftIO $ FFI.afterLockLockableCtx ctx+  pure result+#else+acquire :: Lock -> a -> a+acquire _lock takeLock = takeLock+#endif++{-# INLINE tryAcquire #-}+#ifdef TRACY_ENABLE+tryAcquire :: MonadIO m => Lock -> m Bool -> m Bool+tryAcquire (Lock ctx) tryTakeLock = do+  acquired <- tryTakeLock+  liftIO . FFI.afterTryLockLockableCtx ctx $ fromBool acquired+  pure acquired+#else+tryAcquire :: Lock -> a -> a+tryAcquire _lock tryTakeLock = tryTakeLock+#endif++{-# INLINE release #-}+#ifdef TRACY_ENABLE+release :: MonadIO m => Lock -> m a -> m a+release (Lock ctx) releaseLock = do+  liftIO $ FFI.beforeUnlockLockableCtx ctx+  releaseLock+#else+release :: Lock -> a -> a+release _lock releaseLock = releaseLock+#endif++{-# INLINE mark #-}+mark :: MonadIO m => Lock -> SourceLocation -> m ()+#ifdef TRACY_ENABLE+mark (Lock ctx) (SourceLocation location) = liftIO $ FFI.markLockableCtx ctx location+#else+mark _lock _location = pure ()+#endif++{-# INLINE customName #-}+customName :: MonadIO m => Lock -> Text -> m ()+#ifdef TRACY_ENABLE+customName (Lock ctx) txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.customNameLockableCtx ctx (ConstPtr txtPtr) (FFI.clampTextBytes txtSz)+#else+customName _lock _txt = pure ()+#endif

@@ -3,7 +3,11 @@  {-| Tracing memory allocations -https://github.com/wolfpld/tracy/blob/master/manual/tracy.md#memory-profiling-memoryprofiling+https://github.com/wolfpld/tracy/releases/download/v0.15.0/tracy.pdf++Events have to reach Tracy in the order the allocations and frees really happened.+If several threads allocate at once, hold a lock across each allocation or free and its report.+Otherwise a freed address can be handed out again and reported before its free is, which fails the capture. -}  module System.Tracy.Memory@@ -13,6 +17,7 @@     -- * Memory pools   , allocNamed   , freeNamed+  , discard   ) where  import Control.Monad.IO.Class (MonadIO(..))@@ -30,55 +35,63 @@ {-# INLINE alloc #-} alloc   :: MonadIO m-  => Bool  -- ^ secure-  -> Ptr a -- ^ address to register+  => 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)+alloc ptr size =+  liftIO $ FFI.emitMemoryAlloc (ConstPtr $ castPtr ptr) (fromIntegral size) #else-alloc _secure _ptr _size = pure ()+alloc _ptr _size = pure () #endif  {-# INLINE free #-} free   :: MonadIO m-  => Bool  -- ^ secure-  -> Ptr a -- ^ address that was registered+  => Ptr a -- ^ address that was registered   -> m () #ifdef TRACY_ENABLE-free secure ptr =-  liftIO $ FFI.emitMemoryFree (ConstPtr $ castPtr ptr) (fromIntegral $ fromEnum secure)+free ptr =+  liftIO $ FFI.emitMemoryFree (ConstPtr $ castPtr ptr) #else-free _secure _ptr = pure ()+free _ptr = pure () #endif  {-# INLINE allocNamed #-} allocNamed   :: MonadIO m-  => Bool  -- ^ secure-  -> Ptr a -- ^ address to register+  => 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)+allocNamed ptr size name =+  liftIO $ FFI.emitMemoryAllocNamed (ConstPtr $ castPtr ptr) (fromIntegral size) (ConstPtr $ Ptr name) #else-allocNamed _secure _ptr _size _name = pure ()+allocNamed _ptr _size _name = pure () #endif  {-# INLINE freeNamed #-} freeNamed   :: MonadIO m-  => Bool  -- ^ secure-  -> Ptr a -- ^ address that was registered+  => 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)+freeNamed ptr name =+  liftIO $ FFI.emitMemoryFreeNamed (ConstPtr $ castPtr ptr) (ConstPtr $ Ptr name) #else-freeNamed _secure _ptr _name = pure ()+freeNamed _ptr _name = pure ()+#endif++{-# INLINE discard #-}+discard+  :: MonadIO m+  => Addr# -- ^ memory pool name+  -> m ()+#ifdef TRACY_ENABLE+discard name =+  liftIO $ FFI.emitMemoryDiscard (ConstPtr $ Ptr name)+#else+discard _name = pure () #endif

@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}++module System.Tracy.Section+  ( -- * Scoped sections+    with+  , withCategory++    -- * Manual sections+  , Section(..)+  , enter+  , enterCategory+  , leave++    -- * Categories+  , setup+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Text (Text)+import Data.Word (Word16, Word32)++#ifdef TRACY_ENABLE+import Control.Exception (bracket)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.Text.Foreign qualified as Text+import Foreign.C.ConstPtr (ConstPtr(..))++import System.Tracy.FFI qualified as FFI+import System.Tracy.FFI.Types (clampTextBytes)+#endif++newtype Section = Section Word32++{-# INLINE enter #-}+enter :: MonadIO m => Text -> m Section+enter = enterCategory 0++{-# INLINE enterCategory #-}+enterCategory :: MonadIO m => Word16 -> Text -> m Section+#ifdef TRACY_ENABLE+enterCategory category txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    Section <$> FFI.sectionEnter category (ConstPtr txtPtr) (clampTextBytes txtSz)+#else+enterCategory _category _txt = pure $ Section 0+#endif++{-# INLINE leave #-}+leave :: MonadIO m => Section -> m ()+#ifdef TRACY_ENABLE+leave (Section sectionId) = liftIO $ FFI.sectionLeave sectionId+#else+leave _section = pure ()+#endif++{-# INLINE setup #-}+setup :: MonadIO m => Word16 -> Text -> m ()+#ifdef TRACY_ENABLE+setup category txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.sectionSetup category (ConstPtr txtPtr) (clampTextBytes txtSz)+#else+setup _category _txt = pure ()+#endif++#ifdef TRACY_ENABLE+with :: MonadUnliftIO m => Text -> m a -> m a+with = withCategory 0++withCategory :: MonadUnliftIO m => Word16 -> Text -> m a -> m a+withCategory category txt action =+  withRunInIO \run ->+    bracket (enterCategory category txt) leave \_section -> run action+#else+with :: Text -> a -> a+with _txt action = action++withCategory :: Word16 -> Text -> a -> a+withCategory _category _txt action = action+#endif

@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}++module System.Tracy.SharedLock+  ( -- * Lifetime+    SharedLock(..)+  , announce+  , terminate++    -- * Exclusive locking+  , acquire+  , tryAcquire+  , release++    -- * Shared locking+  , acquireShared+  , tryAcquireShared+  , releaseShared++    -- * Annotations+  , mark+  , customName+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Text (Text)++#ifdef TRACY_ENABLE+import Control.Monad (when)+import Data.Text.Foreign qualified as Text+import Foreign.C.ConstPtr (ConstPtr(..))+import Foreign.Marshal.Utils (fromBool)++import System.Tracy.FFI qualified as FFI+#else+import Foreign.Ptr (nullPtr)+#endif++import System.Tracy.FFI.Types qualified as FFI+import System.Tracy.SourceLocation (SourceLocation(..))++newtype SharedLock = SharedLock FFI.TracyCSharedLockCtx++{-# INLINE announce #-}+announce :: MonadIO m => SourceLocation -> m SharedLock+#ifdef TRACY_ENABLE+announce (SourceLocation location) = liftIO $ SharedLock <$> FFI.announceSharedLockableCtx location+#else+announce _location = pure . SharedLock $ FFI.TracyCSharedLockCtx nullPtr+#endif++{-# INLINE terminate #-}+terminate :: MonadIO m => SharedLock -> m ()+#ifdef TRACY_ENABLE+terminate (SharedLock ctx) = liftIO $ FFI.terminateSharedLockableCtx ctx+#else+terminate _lock = pure ()+#endif++{-# INLINE acquire #-}+#ifdef TRACY_ENABLE+acquire :: MonadIO m => SharedLock -> m a -> m a+acquire (SharedLock ctx) takeLock = do+  waitRecorded <- liftIO $ FFI.beforeLockSharedLockableCtx ctx+  result <- takeLock+  when (waitRecorded /= 0) . liftIO $ FFI.afterLockSharedLockableCtx ctx+  pure result+#else+acquire :: SharedLock -> a -> a+acquire _lock takeLock = takeLock+#endif++{-# INLINE tryAcquire #-}+#ifdef TRACY_ENABLE+tryAcquire :: MonadIO m => SharedLock -> m Bool -> m Bool+tryAcquire (SharedLock ctx) tryTakeLock = do+  acquired <- tryTakeLock+  liftIO . FFI.afterTryLockSharedLockableCtx ctx $ fromBool acquired+  pure acquired+#else+tryAcquire :: SharedLock -> a -> a+tryAcquire _lock tryTakeLock = tryTakeLock+#endif++{-# INLINE release #-}+#ifdef TRACY_ENABLE+release :: MonadIO m => SharedLock -> m a -> m a+release (SharedLock ctx) releaseLock = do+  liftIO $ FFI.beforeUnlockSharedLockableCtx ctx+  releaseLock+#else+release :: SharedLock -> a -> a+release _lock releaseLock = releaseLock+#endif++{-# INLINE acquireShared #-}+#ifdef TRACY_ENABLE+acquireShared :: MonadIO m => SharedLock -> m a -> m a+acquireShared (SharedLock ctx) takeLock = do+  waitRecorded <- liftIO $ FFI.beforeLockSharedSharedLockableCtx ctx+  result <- takeLock+  when (waitRecorded /= 0) . liftIO $ FFI.afterLockSharedSharedLockableCtx ctx+  pure result+#else+acquireShared :: SharedLock -> a -> a+acquireShared _lock takeLock = takeLock+#endif++{-# INLINE tryAcquireShared #-}+#ifdef TRACY_ENABLE+tryAcquireShared :: MonadIO m => SharedLock -> m Bool -> m Bool+tryAcquireShared (SharedLock ctx) tryTakeLock = do+  acquired <- tryTakeLock+  liftIO . FFI.afterTryLockSharedSharedLockableCtx ctx $ fromBool acquired+  pure acquired+#else+tryAcquireShared :: SharedLock -> a -> a+tryAcquireShared _lock tryTakeLock = tryTakeLock+#endif++{-# INLINE releaseShared #-}+#ifdef TRACY_ENABLE+releaseShared :: MonadIO m => SharedLock -> m a -> m a+releaseShared (SharedLock ctx) releaseLock = do+  liftIO $ FFI.beforeUnlockSharedSharedLockableCtx ctx+  releaseLock+#else+releaseShared :: SharedLock -> a -> a+releaseShared _lock releaseLock = releaseLock+#endif++{-# INLINE mark #-}+mark :: MonadIO m => SharedLock -> SourceLocation -> m ()+#ifdef TRACY_ENABLE+mark (SharedLock ctx) (SourceLocation location) = liftIO $ FFI.markSharedLockableCtx ctx location+#else+mark _lock _location = pure ()+#endif++{-# INLINE customName #-}+customName :: MonadIO m => SharedLock -> Text -> m ()+#ifdef TRACY_ENABLE+customName (SharedLock ctx) txt = liftIO $+  Text.withCStringLen txt \(txtPtr, txtSz) ->+    FFI.customNameSharedLockableCtx ctx (ConstPtr txtPtr) (FFI.clampTextBytes txtSz)+#else+customName _lock _txt = pure ()+#endif

@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}++module System.Tracy.SourceLocation+  ( SourceLocation(..)+  , newSourceLocation+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.ByteString (ByteString)+import Foreign.C.ConstPtr (ConstPtr(..))+import Foreign.Ptr (nullPtr)++#ifdef TRACY_ENABLE+import Data.ByteString.Char8 qualified as ByteString+import Foreign.C.String (newCAString)+import Foreign.Marshal.Utils (new)+import GHC.Stack (HasCallStack, SrcLoc(..), callStack, getCallStack)+#endif++import System.Tracy.FFI.Types qualified as FFI++newtype SourceLocation = SourceLocation (ConstPtr FFI.SourceLocationData)++#ifdef TRACY_ENABLE+newSourceLocation :: (HasCallStack, MonadIO m) => ByteString -> FFI.Color -> m SourceLocation+newSourceLocation function color = liftIO case getCallStack callStack of+  (_called, SrcLoc{srcLocFile, srcLocStartLine}) : _callers -> do+    functionName <- newCAString (ByteString.unpack function)+    fileName <- newCAString srcLocFile+    SourceLocation . ConstPtr <$>+      new (FFI.SourceLocationData nullPtr functionName fileName (fromIntegral srcLocStartLine) color)+  [] ->+    error "newSourceLocation ought to have HasCallStack in context"+#else+newSourceLocation :: MonadIO m => ByteString -> FFI.Color -> m SourceLocation+newSourceLocation _function _color = pure $ SourceLocation (ConstPtr nullPtr)+#endif

@@ -4,6 +4,7 @@ module System.Tracy.Zone   ( -- * Declare zones     withSrcLoc+  , withSourceLocation      -- * Update zone context   , text@@ -28,23 +29,26 @@ import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Text.Foreign qualified as Text import Foreign.C.ConstPtr (ConstPtr(..))+import Foreign.C.String (peekCAString)+import Foreign.Storable (peek) import GHC.Stack import GHC.Stack.Types qualified as GHC  #ifndef ZONES_UNSAFE-import Control.Concurrent (isCurrentThreadBound)+import Control.Concurrent (isCurrentThreadBound, rtsSupportsBoundThreads)+-- !unsafe+#endif #ifdef ZONES_PEDANTIC import System.Exit (die) -- pedantic #endif--- !unsafe-#endif  import System.Tracy.FFI qualified as FFI -- enable #endif  import System.Tracy.FFI.Types qualified as FFI+import System.Tracy.SourceLocation (SourceLocation(..))  {- | Allocate SrcLoc and run a Zone with it. @@ -60,8 +64,11 @@   -- ... @ -NB: Zones can only be used on a bound thread.-Main thread is safe, but the rest should use one of forkOn/asyncBound/runInBoundThread.+NB: With the threaded runtime, zones can only be used on a bound thread.+Main thread is safe, but the rest should use one of forkOS/asyncBound/runInBoundThread.++The non-threaded runtime has no bound threads and runs everything on a single OS thread, so the check is skipped there.+Zones from different Haskell threads must not overlap in that case, or the capture will fail. -} {-# INLINE withSrcLoc #-} withSrcLoc@@ -112,35 +119,77 @@ withSrcLocImpl _line _file _function _col inIO action =   inIO $ let ?zoneCtx = FFI.nullTracyCZoneCtx in action #else-withSrcLocImpl line file function col inIO action = do-#ifdef ZONES_UNSAFE+withSrcLocImpl line file function col inIO action =   runZone+    (pure $ ByteString.unpack file <> ":" <> show line)+    inIO+    (allocSrcloc line file function Nothing col >>= \srcloc -> FFI.emitZoneBeginAlloc srcloc 1)+    action+-- TRACY_ENABLE+#endif++{-# INLINE withSourceLocation #-}+#ifdef TRACY_ENABLE+withSourceLocation+  :: MonadUnliftIO m+  => SourceLocation+  -> ((?zoneCtx :: FFI.TracyCZoneCtx) => m a)+  -> m a+withSourceLocation location@(SourceLocation locationData) action = withRunInIO \inIO ->+  runZone+    (describeSourceLocation location)+    inIO+    (FFI.emitZoneBegin locationData 1)+    action #else-  bound <- isCurrentThreadBound-  if bound then-    runZone+withSourceLocation+  :: SourceLocation+  -> ((?zoneCtx :: FFI.TracyCZoneCtx) => m a)+  -> m a+withSourceLocation _location action = let ?zoneCtx = FFI.nullTracyCZoneCtx in action+#endif++#ifdef TRACY_ENABLE+{-# INLINE runZone #-}+runZone+  :: IO String+  -> (m a -> IO a)+  -> IO FFI.TracyCZoneCtx+  -> ((?zoneCtx :: FFI.TracyCZoneCtx) => m a)+  -> IO a+runZone location inIO beginZone action = do+  onStableOsThread <- canStartZone+  if onStableOsThread then+    bracket beginZone FFI.emitZoneEnd \ctx -> inIO $ let ?zoneCtx = ctx in action   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"+    unboundZone location . inIO $ let ?zoneCtx = FFI.nullTracyCZoneCtx in action++{-# INLINE canStartZone #-}+canStartZone :: IO Bool+#ifdef ZONES_UNSAFE+canStartZone = pure True #else-    inIO $ let ?zoneCtx = FFI.nullTracyCZoneCtx in action+canStartZone = if rtsSupportsBoundThreads then isCurrentThreadBound else pure True #endif --- ZONES_UNSAFE+unboundZone :: IO String -> IO a -> IO a+#ifdef ZONES_PEDANTIC+unboundZone location _withoutZone = do+  {-+    XXX: Will not actually crash the whole program, only the thread.+    But at least there would be a console notice when this happens.+  -}+  zoneLocation <- location+  die $ zoneLocation <> " Starting a zone on unbound thread"+#else+unboundZone _location withoutZone = withoutZone #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++describeSourceLocation :: SourceLocation -> IO String+describeSourceLocation (SourceLocation (ConstPtr locationData)) = do+  FFI.SourceLocationData{file, line} <- peek locationData+  fileName <- peekCAString file+  pure $ fileName <> ":" <> show line #endif  {- | Prepare a single-use location identifier@@ -183,16 +232,6 @@             col #endif -{- 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 #-} #ifndef TRACY_ENABLE text :: MonadIO m => Text -> m ()@@ -201,7 +240,7 @@ text :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => Text -> m () text txt = liftIO $   Text.withCStringLen txt \(txtPtr, txtSz) ->-    FFI.emitZoneText ?zoneCtx (ConstPtr txtPtr) (fromIntegral txtSz)+    FFI.emitZoneText ?zoneCtx (ConstPtr txtPtr) (FFI.clampTextBytes txtSz) #endif  {-# INLINE name #-}@@ -212,7 +251,7 @@ name :: (MonadIO m, ?zoneCtx :: FFI.TracyCZoneCtx) => Text -> m () name txt = liftIO $   Text.withCStringLen txt \(txtPtr, txtSz) ->-    FFI.emitZoneName ?zoneCtx (ConstPtr txtPtr) (fromIntegral txtSz)+    FFI.emitZoneName ?zoneCtx (ConstPtr txtPtr) (FFI.clampTextBytes txtSz) #endif  {-# INLINE color #-}

@@ -4,12 +4,18 @@  module Main where +import Control.Monad (unless, when)+import System.Exit (die)+import System.IO (hPutStrLn, stderr) 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+  when Tracy.enabled do+    hPutStrLn stderr "Waiting for tracy-capture or tracy-profiler to connect on port 8086"+    isConnected <- Tracy.waitConnected 100000 (Just 30_000_000)+    unless isConnected $ die "Nothing connected within 30 seconds"   Tracy.withSrcLoc "main.nowhereInParticular" #f0fa do     Tracy.messageL "hi there"# -- static strings require no copying to be logged     mapM_ runFrame [0..600]

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.1.+-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack  name:           tracy-profiler-version:        0.1.2.1+version:        0.2.0.0 synopsis:       Haskell bindings for Tracy frame profiler category:       Profiling homepage:       https://github.com/haskell-game/tracy-profiler#readme@@ -65,7 +65,12 @@       System.Tracy       System.Tracy.FFI       System.Tracy.FFI.Types+      System.Tracy.Gpu+      System.Tracy.Lock       System.Tracy.Memory+      System.Tracy.Section+      System.Tracy.SharedLock+      System.Tracy.SourceLocation       System.Tracy.Zone   other-modules:       Paths_tracy_profiler@@ -87,7 +92,7 @@       ImplicitParams   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+      base >=4.18 && <5     , bytestring     , text >=2.0 && <3     , unliftio-core@@ -95,13 +100,21 @@   default-language: GHC2021   if flag(enable)     cpp-options: -DTRACY_ENABLE+    cc-options: -DTRACY_ENABLE+    c-sources:+        cbits/gpu_shim.c+        cbits/layout_check.c+        cbits/section_shim.c     extra-libraries:         TracyClient         stdc+++    if flag(on_demand)+      cpp-options: -DTRACY_ON_DEMAND+      cc-options: -DTRACY_ON_DEMAND+      c-sources:+          cbits/zone_shim.c   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)@@ -134,7 +147,7 @@       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+      base >=4.18 && <5     , random     , text     , tracy-profiler