diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/cbits/gpu_shim.c b/cbits/gpu_shim.c new file mode 100644 --- /dev/null +++ b/cbits/gpu_shim.c @@ -0,0 +1,124 @@ +#include +#include + +#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); +} diff --git a/cbits/layout_check.c b/cbits/layout_check.c new file mode 100644 --- /dev/null +++ b/cbits/layout_check.c @@ -0,0 +1,14 @@ +#include +#include + +#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"); diff --git a/cbits/section_shim.c b/cbits/section_shim.c new file mode 100644 --- /dev/null +++ b/cbits/section_shim.c @@ -0,0 +1,14 @@ +#include +#include + +#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 : ""); +} diff --git a/cbits/zone_shim.c b/cbits/zone_shim.c new file mode 100644 --- /dev/null +++ b/cbits/zone_shim.c @@ -0,0 +1,64 @@ +#include +#include + +#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); +} diff --git a/src/System/Tracy.hs b/src/System/Tracy.hs --- a/src/System/Tracy.hs +++ b/src/System/Tracy.hs @@ -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 diff --git a/src/System/Tracy/FFI.hs b/src/System/Tracy/FFI.hs --- a/src/System/Tracy/FFI.hs +++ b/src/System/Tracy/FFI.hs @@ -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 () ---------------------------------------------------------------- diff --git a/src/System/Tracy/FFI/Types.hs b/src/System/Tracy/FFI/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/FFI/Types.hs @@ -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 diff --git a/src/System/Tracy/FFI/Types.hsc b/src/System/Tracy/FFI/Types.hsc deleted file mode 100644 --- a/src/System/Tracy/FFI/Types.hsc +++ /dev/null @@ -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) diff --git a/src/System/Tracy/Gpu.hs b/src/System/Tracy/Gpu.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/Gpu.hs @@ -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 diff --git a/src/System/Tracy/Lock.hs b/src/System/Tracy/Lock.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/Lock.hs @@ -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 diff --git a/src/System/Tracy/Memory.hs b/src/System/Tracy/Memory.hs --- a/src/System/Tracy/Memory.hs +++ b/src/System/Tracy/Memory.hs @@ -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 diff --git a/src/System/Tracy/Section.hs b/src/System/Tracy/Section.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/Section.hs @@ -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 diff --git a/src/System/Tracy/SharedLock.hs b/src/System/Tracy/SharedLock.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/SharedLock.hs @@ -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 diff --git a/src/System/Tracy/SourceLocation.hs b/src/System/Tracy/SourceLocation.hs new file mode 100644 --- /dev/null +++ b/src/System/Tracy/SourceLocation.hs @@ -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 diff --git a/src/System/Tracy/Zone.hs b/src/System/Tracy/Zone.hs --- a/src/System/Tracy/Zone.hs +++ b/src/System/Tracy/Zone.hs @@ -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 #-} diff --git a/test/Readme.hs b/test/Readme.hs --- a/test/Readme.hs +++ b/test/Readme.hs @@ -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] diff --git a/tracy-profiler.cabal b/tracy-profiler.cabal --- a/tracy-profiler.cabal +++ b/tracy-profiler.cabal @@ -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