From 2244afc8dfa69cc51d95fae8e6908dbb2f26fdcb Mon Sep 17 00:00:00 2001 From: Attilio Pittelli Date: Sat, 25 Jul 2026 18:27:16 +0200 Subject: [PATCH] Add experimental macOS tracing backend Signed-off-by: Attilio Pittelli --- .gitignore | 3 + README.md | 10 + macos/PERFORMANCE.md | 104 +++ macos/README.md | 520 +++++++++++ macos/benchmark_mock_processor_trace.ml | 101 +++ macos/benchmark_overhead.ml | 177 ++++ macos/demo.c | 74 ++ macos/dune | 35 + macos/magic_trace_macos.ml | 146 ++++ macos/magic_trace_macos_lib.ml | 1051 +++++++++++++++++++++++ macos/magic_trace_macos_lib.mli | 74 ++ macos/mock_processor_trace.ml | 261 ++++++ macos/mock_processor_trace.mli | 48 ++ macos/mock_processor_trace_cli.ml | 100 +++ macos/test_magic_trace_macos.ml | 168 ++++ macos/test_mock_processor_trace.ml | 91 ++ 16 files changed, 2963 insertions(+) create mode 100644 macos/PERFORMANCE.md create mode 100644 macos/README.md create mode 100644 macos/benchmark_mock_processor_trace.ml create mode 100644 macos/benchmark_overhead.ml create mode 100644 macos/demo.c create mode 100644 macos/dune create mode 100644 macos/magic_trace_macos.ml create mode 100644 macos/magic_trace_macos_lib.ml create mode 100644 macos/magic_trace_macos_lib.mli create mode 100644 macos/mock_processor_trace.ml create mode 100644 macos/mock_processor_trace.mli create mode 100644 macos/mock_processor_trace_cli.ml create mode 100644 macos/test_magic_trace_macos.ml create mode 100644 macos/test_mock_processor_trace.ml diff --git a/.gitignore b/.gitignore index b961741af..c43600316 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,6 @@ perf.data.old *.fxt.gz.old *.fxt.zst *.fxt.zst.old +*.trace +trace.json +trace.json.gz diff --git a/README.md b/README.md index 832a55e44..99b196e10 100644 --- a/README.md +++ b/README.md @@ -64,6 +64,16 @@ You can point magic-trace at a function such that when your application calls it Then, test it by running `magic-trace -help`, which should bring up some help text. +## Experimental Apple Silicon backend + +An experimental native OCaml backend for macOS is available under +[`macos/`](macos/README.md). The working M1 Pro path uses Xcode's Time Profiler +and produces approximately 1 ms sampled stacks rather than the original +backend's complete ~40 ns control-flow trace. A separate OCaml hardware model +validates exact 40 ns reconstruction and decoder throughput without presenting +synthetic data as a real capture. See the macOS documentation for architecture, +build, test, benchmark, limitation, and hardware-backend roadmap details. + [^3]: Strictly speaking, anything newer than Broadwell, but this is not a platform we regularly test on, and timing resolution is worse (~1us). [^4]: https://github.com/actions/upload-artifact/issues/38 diff --git a/macos/PERFORMANCE.md b/macos/PERFORMANCE.md new file mode 100644 index 000000000..e950b5856 --- /dev/null +++ b/macos/PERFORMANCE.md @@ -0,0 +1,104 @@ +# macOS performance results + +This document separates target-process overhead from trace fidelity. Both +matter when comparing this backend with the original Intel Processor Trace +implementation. + +## Test system + +- Apple M1 Pro +- macOS 26.5.2 +- Xcode `xctrace` 16.0 (17F113) +- OCaml 5.5.0 +- Dune 3.24.1 +- Demo compiled as a native arm64 Mach-O with `clang -O2 -g` + +## Target-process overhead + +The native OCaml benchmark ran ten balanced baseline/traced pairs with 5,000 +fixed demo iterations per measurement. It alternated baseline-first and +traced-first ordering and verified the same workload checksum in every pair. + +```text +runs=10 +mean_overhead=+0.779% +standard_deviation=1.264% +approximate_95%_confidence_interval=[-0.004%, +1.563%] +overhead_gate=PASS +``` + +The confidence interval's upper bound is below the original project's +published 10% upper bound. Individual pairs can report negative overhead due +to measurement noise; that is not a claim that profiling makes the program +faster. + +Reproduce the result using: + +```sh +dune build macos/benchmark_overhead.exe +clang -O2 -g -Wall -Wextra -Werror \ + macos/demo.c -o /tmp/magic-trace-macos-demo + +_build/default/macos/benchmark_overhead.exe \ + --runs 10 \ + --iterations 5000 \ + /tmp/magic-trace-macos-demo +``` + +## Conversion performance + +Converting a 393 KiB Time Profiler XML export containing 2,002 samples and +2,925 reconstructed intervals took 0.04 seconds and produced a 23 KiB +compressed trace. + +Conversion happens after recording, so it does not add overhead to the target +process. + +## Fidelity + +The recorded median sampling period was 1,000,000 ns. The original +magic-trace backend advertises complete function-call tracing at approximately +40 ns resolution. + +| Property | Original Intel backend | M1 Time Profiler backend | +|---|---:|---:| +| Runtime-overhead gate | 2–10% | Passes the 10% ceiling | +| Time resolution | ~40 ns | 1,000,000 ns | +| Relative resolution | 1× | 25,000× coarser | +| Captures every function call | Yes | No | + +The M1 backend therefore reaches the runtime-overhead target but cannot reach +the original trace-fidelity target. OCaml removes the prototype-language +difference; it cannot replace processor trace hardware that is absent from the +M1. + +## Synthetic 40 ns hardware model + +`mock_processor_trace_cli.exe` supplies deterministic compressed packets at the +boundary where a future Apple Processor Trace capture provider will connect. +The model uses: + +- a 40 ns virtual event period; +- two call/return decisions per byte; +- one 64-bit timing anchor every 4,096 events; +- balanced nested calls with exact expected start and end times. + +`benchmark_mock_processor_trace.exe` gates the OCaml decoder against 25 million +events per second, which is one event slot every 40 ns. This is deliberately a +software readiness benchmark. Passing it does not claim that an M1 acquired +real branch data, nor does it replace an overhead measurement on supported +Processor Trace hardware. + +On the M1 Pro test system, five decodes of a 10,000,000-event stream produced: + +```text +median_decode_rate=67.361M events/s +required_rate=25.000M events/s +realtime_factor=2.69x +synthetic_packet_bandwidth=12.555MB/s +decoder_realtime_gate=PASS +``` + +The checksum was identical in all five runs. At this model's worst-case rate, +the OCaml decoder therefore has substantial headroom; real Apple packet parsing +and trace acquisition remain the unmeasured parts. diff --git a/macos/README.md b/macos/README.md new file mode 100644 index 000000000..3383120c7 --- /dev/null +++ b/macos/README.md @@ -0,0 +1,520 @@ +# Experimental macOS backend + +This directory contains an experimental Apple Silicon backend for +`magic-trace`. It is implemented in native OCaml and produces timeline files +that can be opened by [magic-trace.org](https://magic-trace.org/) or the +standard [Perfetto UI](https://ui.perfetto.dev/). + +The project currently provides two complementary paths: + +1. A **working Time Profiler backend** that records a real macOS process with + Xcode Instruments and converts its sampled stacks into estimated intervals. +2. A **synthetic Processor Trace model** that tests exact 40 ns call + reconstruction and OCaml decoder throughput without claiming that an M1 + captured real processor-trace packets. + +The implementation language is OCaml. The only C source in this directory is a +deterministic workload used by the smoke test and overhead benchmark. + +## Status + +| Capability | Status | Meaning | +|---|---|---| +| Launch and profile a command | Working | Uses Xcode's Time Profiler template | +| Attach to an existing process | Working | Records the selected PID | +| Convert an Instruments export | Working | Reads the `time-profile` XML schema | +| Perfetto/magic-trace.org output | Working | Writes Chrome Trace Event JSON, optionally gzip-compressed | +| Apple M1 Pro validation | Working | Build, correctness, recording, conversion, and overhead tested | +| 40 ns synthetic reconstruction | Working | Exact virtual timestamps; no sampling | +| 40 ns OCaml decoder-rate gate | Working | Median 67.36 million modeled events/s on the latest M1 Pro validation run | +| Real Apple Processor Trace capture | Not implemented | Requires supported hardware, an exportable packet source, and an ARM64 decoder | +| Original function-trigger snapshots | Not implemented | The fallback records a fixed time window | + +The Time Profiler and synthetic paths answer different questions: + +- Time Profiler proves that the OCaml CLI, Instruments integration, + symbolication import, interval reconstruction, and trace export work on a + real M1 Pro. +- The mock proves that the current OCaml decoder design can process a + conservative 40 ns event stream faster than real time. +- Neither result proves that an M1 can perform hardware control-flow tracing. + It cannot be made equivalent to Intel Processor Trace through faster + software sampling. + +## Why the original backend cannot simply be reused + +The original Linux backend relies on Intel Processor Trace (Intel PT). The CPU +stores compressed control-flow information in hardware while the target runs; +software later combines those packets with the executable to reconstruct calls +and returns. The advertised approximately 40 ns figure is trace resolution, +not a stack-sampling interrupt every 40 ns. + +Xcode Time Profiler takes periodic stack samples instead. On the validated M1 +Pro configuration, the median period is 1,000,000 ns. A call that starts and +finishes between two samples is invisible, and visible function boundaries are +estimates. A 40 ns software sampler would require 25 million interrupts and +stack unwinds per second, so it is not a viable substitute for hardware trace. + +## Architecture + +### Real M1 fallback + +```text +target process + | + v +Xcode xctrace / Time Profiler + | + v +Instruments .trace recording + | + v +xctrace time-profile XML export + | + v +OCaml XML parser and id/ref resolver + | + v +gap-aware sampled-stack interval reconstruction + | + v +Perfetto-compatible JSON or JSON.gz +``` + +The XML parser supports the compression used by `xctrace export`, including +reused `id`/`ref` elements and `sentinel` columns. Samples are grouped by +process and thread, stacks are converted to root-first order, and common stack +prefixes are extended across adjacent samples. Gaps close the active stack so +unobserved time is not presented as continuous execution. + +Every output interval from this path is tagged as estimated from samples. The +trace metadata also records the median sampling period and a warning about +missing short calls. + +### Synthetic 40 ns model + +```text +deterministic nested-call workload + | + v +two call/return decisions per byte +plus sparse 64-bit timing anchors + | + v +OCaml packet decoder and call-stack machine + | + +--> checksum and throughput statistics + | + v +exact synthetic intervals in Perfetto JSON +``` + +The synthetic packet format is intentionally small and deterministic: + +- identifiers `1` through `14` represent calls; +- identifier `0` represents a return; +- two decisions are packed into each byte; +- `0xff` introduces a little-endian 64-bit timing anchor; +- the default anchor interval is 4,096 events; +- the default virtual event spacing is exactly 40 ns. + +This is an internal performance model, **not Apple's packet format**. It lets +development continue without compatible hardware and establishes an executable +performance gate for the OCaml portion of the design. + +## Source layout + +| File | Purpose | +|---|---| +| `magic_trace_macos.ml` | `run`, `attach`, and `convert` command-line interface | +| `magic_trace_macos_lib.ml` | Instruments control, XML parsing, interval reconstruction, and JSON writing | +| `mock_processor_trace.ml` | Synthetic packet generator, decoder, stack reconstruction, and JSON writer | +| `mock_processor_trace_cli.ml` | Creates a small visual 40 ns trace | +| `benchmark_mock_processor_trace.ml` | Measures modeled decoder throughput | +| `benchmark_overhead.ml` | Compares real target runtime with and without Time Profiler | +| `test_magic_trace_macos.ml` | Tests XML handling, sampled intervals, durations, and JSON | +| `test_mock_processor_trace.ml` | Tests exact 40 ns calls, timing anchors, and simulated metadata | +| `demo.c` | CPU-bound workload with stable, non-inlined nested functions | +| `PERFORMANCE.md` | Reproducible measurements and fidelity comparison | + +## Requirements + +- macOS on Apple Silicon +- A full Xcode installation containing `xctrace` +- OCaml 4.14 or newer +- Dune 3.0 or newer +- `clang` for the demonstration workload +- Developer Tools permission when macOS requests it + +The production macOS code depends only on the OCaml standard library and +`unix`. It does not require Jane Street's `Core`, PPX extensions, Python, or a +new C binding. + +Install the standalone build tools with Homebrew if needed: + +```sh +brew install ocaml dune +``` + +For a standard Xcode installation, confirm that `xctrace` is available: + +```sh +/Applications/Xcode.app/Contents/Developer/usr/bin/xctrace version +``` + +The backend checks `MAGIC_TRACE_XCTRACE`, the standard Xcode path, `PATH`, and +finally `xcrun`. If Xcode is installed in a nonstandard location, set +`MAGIC_TRACE_XCTRACE` to the absolute path of its `xctrace` executable. + +## Quick start: record a real process + +Run these commands from the repository root: + +```sh +dune build macos/magic_trace_macos.exe + +clang -O2 -g -Wall -Wextra -Werror \ + macos/demo.c \ + -o /tmp/magic-trace-macos-demo + +_build/default/macos/magic_trace_macos.exe run \ + --duration 4s \ + --output trace.json.gz \ + --force \ + -- /tmp/magic-trace-macos-demo 2 +``` + +The command: + +1. launches the demo through `xctrace`; +2. records Time Profiler samples; +3. exports the symbolicated `time-profile` table; +4. reconstructs estimated intervals in OCaml; +5. writes `trace.json.gz`. + +Open the result at [magic-trace.org](https://magic-trace.org/) or +[ui.perfetto.dev](https://ui.perfetto.dev/). Zoom into the main thread and +look for `main`, `work_a`, `work_b`, and `scramble`. + +Do not expect every invocation of `scramble` to appear: it is deliberately much +shorter than the 1 ms sampling period. + +## Command reference + +### Record a command + +```sh +_build/default/macos/magic_trace_macos.exe run \ + [--duration TIME] \ + [--output TRACE.json.gz] \ + [--keep-recording RECORDING.trace] \ + [--force] \ + -- COMMAND [ARGUMENTS...] +``` + +Example: + +```sh +_build/default/macos/magic_trace_macos.exe run \ + --duration 5s \ + --output my-program.json.gz \ + -- ./my-program argument +``` + +`TIME` accepts values such as `500ms`, `5`, `5s`, `1m`, or `1h`. A bare +integer means seconds. Pick a limit long enough for a short command to start, +perform useful CPU work, and become visible to the sampler. + +The launched command is terminated if it is still running when Instruments +reaches its time limit. Its standard output remains visible in the terminal. + +### Attach to a process + +```sh +_build/default/macos/magic_trace_macos.exe attach \ + --pid 12345 \ + --duration 5s \ + --output attached-process.json.gz +``` + +Recording an attached process does not intentionally terminate that process +when the time limit expires. + +### Keep the Instruments recording + +Preserve the `.trace` bundle when investigating symbolication or export issues: + +```sh +_build/default/macos/magic_trace_macos.exe run \ + --duration 5s \ + --keep-recording recording.trace \ + --output trace.json.gz \ + -- ./my-program +``` + +The destination must not already exist. + +### Convert an existing XML export + +```sh +_build/default/macos/magic_trace_macos.exe convert \ + time-profile.xml \ + --output converted.json.gz \ + --force +``` + +The XML must contain the table whose schema is `time-profile`. This command is +useful for repeatable parser testing because it performs no new recording. + +### Output behavior + +- A filename ending in `.gz` is compressed with `/usr/bin/gzip`. +- Any other filename is written as uncompressed JSON. +- Existing output is preserved unless `--force` is supplied. +- Parent directories are created automatically. +- Recording and conversion happen locally; this backend sends no trace data to + a service. + +## Test the synthetic 40 ns model + +Build a small exact trace: + +```sh +dune exec macos/mock_processor_trace_cli.exe -- \ + --cycles 1000 \ + --resolution-ns 40 \ + --anchor-every 4096 \ + --output mock-40ns-trace.json \ + --force +``` + +The generated trace contains 10,000 call/return events and 5,000 exact +function intervals across 0.4 ms of virtual time. Open it in Perfetto and +inspect the nested `main`, `work_a`, `work_b`, and `scramble` calls. + +Available mock options: + +| Option | Default | Purpose | +|---|---:|---| +| `--cycles N` | 1,000 | Number of deterministic nested-call cycles | +| `--resolution-ns N` | 40 | Virtual time between events | +| `--anchor-every N` | 4,096 | Events between 64-bit timing anchors; must be positive and even | +| `--output FILE` | `mock-40ns-trace.json` | Perfetto JSON destination | +| `--force` | off | Replace an existing destination | + +Large mock traces should be decoded with the benchmark rather than serialized +to JSON. JSON produces one object per reconstructed call and intentionally +measures formatting and file I/O in addition to decoding. + +## Run the decoder-throughput gate + +```sh +dune exec macos/benchmark_mock_processor_trace.exe -- \ + --events 10000000 \ + --runs 5 +``` + +At 40 ns there are 25 million virtual event slots per second. The benchmark +warms the decoder, runs it repeatedly, verifies a stable checksum, and compares +the median rate with 25 million events/s. + +Latest validation on the M1 Pro test system: + +```text +model events=10000000 +virtual_duration=0.400s +required_rate=25.000M_events/s +median_decode_rate=67.361M_events/s +realtime=2.69x +required_stream_rate=12.555MB/s +decoder_realtime_gate=PASS +``` + +This is deliberately stricter than merely reconstructing a trace offline: it +requires the decoder to keep up with one modeled event every 40 ns. Passing the +gate shows software throughput headroom. It does not measure target-process +slowdown, actual Apple packet bandwidth, or hardware capture reliability. + +Use `--no-gate` when collecting diagnostic measurements on a slower machine +without making a low rate fail the command. + +## Correctness tests + +Run the self-contained macOS tests: + +```sh +dune runtest macos --no-buffer +``` + +The tests cover: + +- duration validation; +- XML entity decoding; +- `xctrace` `id`/`ref` resolution; +- `sentinel` column reuse; +- process and thread extraction; +- gap-aware sampled-stack reconstruction; +- Chrome Trace Event JSON output; +- exact 40 ns mock call boundaries; +- sparse timing-anchor validation; +- deterministic decoder checksums; +- explicit simulated-trace metadata; +- output overwrite protection. + +The macOS targets are intentionally independent of the Linux backend's larger +dependency set. A complete repository build still requires all dependencies +listed by the upstream project. + +## Measure real recording overhead + +Build the benchmark and its workload: + +```sh +dune build macos/benchmark_overhead.exe + +clang -O2 -g -Wall -Wextra -Werror \ + macos/demo.c \ + -o /tmp/magic-trace-macos-demo +``` + +Run balanced baseline/traced pairs: + +```sh +_build/default/macos/benchmark_overhead.exe \ + --runs 10 \ + --iterations 5000 \ + /tmp/magic-trace-macos-demo +``` + +The benchmark alternates whether the baseline or traced measurement runs first, +checks that both executions produce the same workload checksum, and reports an +approximate 95% confidence interval. Its gate passes only when the interval's +upper bound is at most 10%, matching the upper end of the original project's +published overhead range. + +The recorded M1 Pro result was: + +```text +mean_overhead=+0.779% +approximate_95%_confidence_interval=[-0.004%, +1.563%] +overhead_gate=PASS +``` + +The confidence interval slightly crosses zero because of measurement noise; +individual pairs with negative overhead are not evidence that profiling +accelerates the program. See [`PERFORMANCE.md`](PERFORMANCE.md) for the +environment, methodology, conversion measurement, and fidelity table. + +## Interpreting the results + +Three independent properties must not be collapsed into one performance +number: + +| Property | Current evidence | Remaining validation | +|---|---|---| +| Target-process overhead | Time Profiler upper confidence bound is below 10% on the test M1 Pro | Repeat across machines and workloads | +| Trace fidelity | Real backend samples at 1 ms; synthetic backend reconstructs exact 40 ns events | Capture real hardware control flow | +| Decoder throughput | Synthetic OCaml decoder reaches 67.36M events/s | Parse Apple's actual packets and metadata | + +The software model therefore clears its intended throughput gate, while the +M1 fallback still does **not** reach Jane Street's all-call trace fidelity. + +## Path to a real Apple Processor Trace backend + +Full parity requires a separate capture provider for Macs on which Apple's +Processor Trace facility is available. The following work remains: + +1. Detect Processor Trace support and retain Time Profiler as the fallback. +2. Start a bounded or rolling trace without instrumenting the target. +3. Export raw trace packets, image load addresses, thread identifiers, + scheduling information, and hardware timing data. +4. Decode ARM64 control flow against the exact Mach-O images used by the + process. +5. Reconstruct direct and indirect calls, returns, branches, exceptions, and + discontinuities across cores. +6. Correlate sparse hardware timing packets with decoded control flow. +7. Feed exact intervals into the trace writer. +8. Add ring-buffer snapshots and function-call triggers. +9. Validate the reconstructed sequence against an instrumented ground-truth + workload. +10. Re-run the 2–10% overhead, approximately 40 ns resolution, and lost-packet + gates on compatible hardware. + +A real backend is acceptable only if the trace records actual target control +flow. Replaying the synthetic format or labelling sampled stacks at 40 ns would +not satisfy that requirement. + +## Known limitations + +- Real M1 traces use approximately 1 ms periodic stack samples. +- Short calls and branches between samples are missing. +- Sample-derived interval boundaries are estimates. +- Only user-space stacks exported by Time Profiler are represented. +- There is no function-call trigger or pre-trigger rolling buffer. +- The real backend depends on Xcode's `time-profile` export schema. +- The synthetic format is not compatible with Apple Processor Trace packets. +- The synthetic benchmark does not measure target overhead. +- Cross-core scheduling and trace discontinuities are not decoded. +- Hardware Processor Trace support has not been validated in this repository. + +## Troubleshooting + +### `xctrace was not found` + +Install full Xcode, then select Command Line Tools in +**Xcode → Settings → Locations**. Verify: + +```sh +xcrun --find xctrace +``` + +If command-line tool selection is intentionally different, point the backend +at the full Xcode installation directly: + +```sh +export MAGIC_TRACE_XCTRACE=/Applications/Xcode.app/Contents/Developer/usr/bin/xctrace +``` + +### Instruments asks for permission or records no stacks + +Allow Developer Tools access in macOS System Settings and rerun the command. +The exact panel name can vary between macOS releases. A CPU-bound target and a +recording of several seconds are easiest to validate. + +### The trace contains no short functions + +That is expected with the real Time Profiler path. Calls shorter than the +sampling interval may never be observed. Use the synthetic trace only to test +the prospective high-fidelity software pipeline; it does not contain data from +your target process. + +### The output already exists + +Choose another filename or pass `--force`. Instruments `.trace` bundles named +by `--keep-recording` are never overwritten. + +### Symbols appear as addresses + +Build the target with debug information, avoid stripping it, and retain the +original executable and dependent images while recording. Use +`--keep-recording` to inspect symbolication directly in Instruments. + +### The whole repository does not build + +The upstream Linux project requires additional packages such as Jane Street +`Core`, PPX tooling, `vec`, and LLVM utilities. The experimental macOS targets +and tests can be built independently with the commands in this README. + +## Pull-request scope + +The macOS work is isolated under `macos/` plus a short link from the root +README. It does not alter the existing Linux/Intel PT backend. This separation +allows review in stages: + +1. accept the OCaml Time Profiler fallback and its tests; +2. accept the clearly labelled synthetic performance harness; +3. add a real Apple Processor Trace provider only after hardware-backed + evidence is available. + +This staging keeps the current contribution useful on an M1 while preserving a +strict definition of full magic-trace fidelity. diff --git a/macos/benchmark_mock_processor_trace.ml b/macos/benchmark_mock_processor_trace.ml new file mode 100644 index 000000000..c6036fa76 --- /dev/null +++ b/macos/benchmark_mock_processor_trace.ml @@ -0,0 +1,101 @@ +open Mock_processor_trace + +let fail format = Printf.ksprintf (fun message -> raise (Invalid_argument message)) format + +let positive_int name value = + match int_of_string_opt value with + | Some value when value > 0 -> value + | _ -> fail "%s must be a positive integer" name + +let option_value name = function + | value :: rest -> value, rest + | [] -> fail "missing value for %s" name + +let usage () = + Printf.printf + {|Benchmark the OCaml synthetic Processor Trace decoder. + +Usage: + benchmark_mock_processor_trace [--events N] [--runs N] [--no-gate] + +The default stream contains 10,000,000 virtual events at 40 ns spacing. The +gate requires decoding at least 25,000,000 events/second, the rate represented +by one 40 ns event slot. Decoding happens after capture on real hardware. +|}; + exit 0 + +let rec parse events runs gate = function + | "--events" :: rest -> + let value, rest = option_value "--events" rest in + parse (positive_int "--events" value) runs gate rest + | "--runs" :: rest -> + let value, rest = option_value "--runs" rest in + parse events (positive_int "--runs" value) gate rest + | "--no-gate" :: rest -> parse events runs false rest + | ("--help" | "-help" | "-h") :: _ -> usage () + | option :: _ -> fail "unknown option: %s" option + | [] -> events, runs, gate + +let median values = + let sorted = List.sort Float.compare values in + List.nth sorted (List.length sorted / 2) + +let run () = + let arguments = + match Array.to_list Sys.argv with + | _ :: arguments -> arguments + | [] -> [] + in + let requested_events, runs, gate = parse 10_000_000 5 true arguments in + let cycles = max 1 ((requested_events + 9) / 10) in + let trace = generate ~resolution_ns:40L ~anchor_every:4_096 ~cycles () in + let events = event_count trace in + let bytes = packet_bytes trace in + let required_rate = 1_000_000_000. /. Int64.to_float (resolution_ns trace) in + Printf.printf + "model events=%d packet_bytes=%d bytes_per_event=%.4f \ + virtual_duration=%.3fs required_rate=%.3fM_events/s\n%!" + events + bytes + (float_of_int bytes /. float_of_int events) + (float_of_int events /. required_rate) + (required_rate /. 1_000_000.); + ignore (decode trace); + let rates = ref [] in + let expected_checksum = ref None in + for index = 1 to runs do + let started = Unix.gettimeofday () in + let stats = decode trace in + let elapsed = Unix.gettimeofday () -. started in + let rate = float_of_int stats.event_count /. elapsed in + (match !expected_checksum with + | None -> expected_checksum := Some stats.checksum + | Some expected when not (Int64.equal expected stats.checksum) -> + fail "decoder checksum changed between runs" + | Some _ -> ()); + rates := rate :: !rates; + Printf.printf + "run=%02d elapsed=%.6fs decode_rate=%.3fM_events/s realtime=%.2fx \ + checksum=%Lx\n%!" + index + elapsed + (rate /. 1_000_000.) + (rate /. required_rate) + stats.checksum + done; + let median_rate = median !rates in + let stream_rate_bytes = required_rate *. (float_of_int bytes /. float_of_int events) in + Printf.printf + "summary median_decode_rate=%.3fM_events/s required_stream_rate=%.3fMB/s \ + decoder_realtime_gate=%s target=>=%.3fM_events/s\n" + (median_rate /. 1_000_000.) + (stream_rate_bytes /. 1_000_000.) + (if median_rate >= required_rate then "PASS" else "FAIL") + (required_rate /. 1_000_000.); + if gate && median_rate < required_rate then exit 1 + +let () = + try run () with + | Invalid_argument message | Decode_error message -> + Printf.eprintf "mock-processor-trace-benchmark: error: %s\n%!" message; + exit 1 diff --git a/macos/benchmark_overhead.ml b/macos/benchmark_overhead.ml new file mode 100644 index 000000000..5b1dbf745 --- /dev/null +++ b/macos/benchmark_overhead.ml @@ -0,0 +1,177 @@ +open Magic_trace_macos_lib + +type measurement = + { elapsed_seconds : float + ; checksum : string + } + +let parse_measurement line = + match String.split_on_char ' ' (String.trim line) with + | [ elapsed; checksum ] -> + let elapsed_seconds = + match float_of_string_opt elapsed with + | Some value when value > 0. -> value + | _ -> failf "invalid benchmark elapsed time: %s" elapsed + in + { elapsed_seconds; checksum } + | _ -> failf "invalid benchmark output: %S" line + +let read_first_line path = + let channel = open_in path in + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> + try input_line channel with + | End_of_file -> failf "benchmark produced no output") + +let baseline demo iterations = + let arguments = [| demo; "--iterations"; string_of_int iterations |] in + let channel = Unix.open_process_args_in demo arguments in + let line = + try input_line channel with + | End_of_file -> + ignore (Unix.close_process_in channel); + failf "baseline benchmark produced no output" + in + (match Unix.close_process_in channel with + | Unix.WEXITED 0 -> parse_measurement line + | Unix.WEXITED code -> failf "baseline benchmark failed with exit code %d" code + | Unix.WSIGNALED signal -> failf "baseline benchmark was killed by signal %d" signal + | Unix.WSTOPPED signal -> failf "baseline benchmark stopped on signal %d" signal) + +let traced xctrace demo iterations = + let rec attempt retries = + try + with_temporary_directory (fun directory -> + let recording = Filename.concat directory "benchmark.trace" in + let target_output = Filename.concat directory "target-output.txt" in + record + ~timeout_seconds:(Some 20.) + ~target_stdout:(Some target_output) + ~xctrace + ~recording + ~duration:"10s" + ~target:(Command [ demo; "--iterations"; string_of_int iterations ]); + read_first_line target_output |> parse_measurement) + with + | Error message when retries > 0 -> + Printf.eprintf "xctrace retry after error: %s\n%!" message; + ignore (Unix.select [] [] [] 0.5); + attempt (retries - 1) + in + attempt 1 + +let mean values = + List.fold_left ( +. ) 0. values /. float_of_int (List.length values) + +let standard_deviation values = + match values with + | [] | [ _ ] -> 0. + | _ -> + let average = mean values in + let squared_error = + List.fold_left + (fun total value -> + let difference = value -. average in + total +. (difference *. difference)) + 0. + values + in + sqrt (squared_error /. float_of_int (List.length values - 1)) + +let rec parse_options runs iterations demo = function + | "--runs" :: value :: rest -> + let runs = + match int_of_string_opt value with + | Some value when value >= 4 -> value + | _ -> failf "--runs must be an integer of at least 4" + in + parse_options runs iterations demo rest + | "--iterations" :: value :: rest -> + let iterations = + match int_of_string_opt value with + | Some value when value > 0 -> value + | _ -> failf "--iterations must be a positive integer" + in + parse_options runs iterations demo rest + | [ value ] -> runs, iterations, value + | [] -> failf "missing path to the compiled demo" + | option :: _ -> failf "unknown benchmark option: %s" option + +let run () = + let arguments = + match Array.to_list Sys.argv with + | _ :: arguments -> arguments + | [] -> [] + in + let runs, iterations, demo = parse_options 10 5_000 "" arguments in + let demo = + match find_on_path demo with + | Some path -> path + | None -> failf "demo executable was not found: %s" demo + in + let xctrace = find_xctrace () in + Printf.printf + "Benchmarking %s with %d fixed iterations across %d balanced pairs.\n%!" + demo + iterations + runs; + ignore (baseline demo (max 1 (iterations / 10))); + let pairs = ref [] in + for index = 0 to runs - 1 do + let baseline_result, traced_result = + if index mod 2 = 0 then + baseline demo iterations, traced xctrace demo iterations + else + let traced_result = traced xctrace demo iterations in + let baseline_result = baseline demo iterations in + baseline_result, traced_result + in + if not (String.equal baseline_result.checksum traced_result.checksum) then + failf + "checksum mismatch in run %d: baseline=%s traced=%s" + (index + 1) + baseline_result.checksum + traced_result.checksum; + let overhead = + ((traced_result.elapsed_seconds /. baseline_result.elapsed_seconds) -. 1.) *. 100. + in + pairs := overhead :: !pairs; + Printf.printf + "run=%02d baseline=%.9fs traced=%.9fs overhead=%+.3f%%\n%!" + (index + 1) + baseline_result.elapsed_seconds + traced_result.elapsed_seconds + overhead + done; + let overheads = List.rev !pairs in + let average = mean overheads in + let deviation = standard_deviation overheads in + let standard_error = deviation /. sqrt (float_of_int runs) in + let lower = average -. (1.96 *. standard_error) in + let upper = average +. (1.96 *. standard_error) in + Printf.printf + "summary runs=%d mean_overhead=%+.3f%% stdev=%.3f%% approximate_95%%_ci=[%+.3f%%,%+.3f%%]\n" + runs + average + deviation + lower + upper; + if upper <= 10. then + Printf.printf "overhead_gate=PASS target=<=10%%\n" + else ( + Printf.printf "overhead_gate=FAIL target=<=10%%\n"; + exit 1) + +let () = + try run () with + | Error message -> + Printf.eprintf "magic-trace-macos-benchmark: error: %s\n%!" message; + exit 1 + | Unix.Unix_error (error, function_name, argument) -> + Printf.eprintf + "magic-trace-macos-benchmark: error: %s(%s): %s\n%!" + function_name + argument + (Unix.error_message error); + exit 1 diff --git a/macos/demo.c b/macos/demo.c new file mode 100644 index 000000000..48ce53fb8 --- /dev/null +++ b/macos/demo.c @@ -0,0 +1,74 @@ +#include +#include +#include +#include +#include + +#if defined(__clang__) || defined(__GNUC__) +#define NOINLINE __attribute__((noinline)) +#else +#define NOINLINE +#endif + +static NOINLINE uint64_t scramble(uint64_t value) { + value ^= value >> 12; + value ^= value << 25; + value ^= value >> 27; + return value * UINT64_C(2685821657736338717); +} + +static NOINLINE uint64_t work_a(uint64_t value) { + for (int index = 0; index < 50000; ++index) + value = scramble(value + (uint64_t)index); + return value; +} + +static NOINLINE uint64_t work_b(uint64_t value) { + for (int index = 0; index < 30000; ++index) + value = scramble(value ^ (uint64_t)index); + return value; +} + +static double monotonic_seconds(void) { + struct timespec time; + clock_gettime(CLOCK_MONOTONIC, &time); + return (double)time.tv_sec + ((double)time.tv_nsec / 1000000000.0); +} + +int main(int argc, char **argv) { + uint64_t value = UINT64_C(0x123456789abcdef); + + if (argc > 1 && strcmp(argv[1], "--iterations") == 0) { + if (argc != 3) { + fprintf(stderr, "usage: %s --iterations COUNT\n", argv[0]); + return 2; + } + + char *end = NULL; + const unsigned long long iterations = strtoull(argv[2], &end, 10); + if (end == argv[2] || *end != '\0' || iterations == 0) { + fprintf(stderr, "invalid iteration count: %s\n", argv[2]); + return 2; + } + + const double start = monotonic_seconds(); + for (unsigned long long iteration = 0; iteration < iterations; ++iteration) { + value = work_a(value); + value = work_b(value); + } + const double elapsed = monotonic_seconds() - start; + printf("%.9f %llu\n", elapsed, (unsigned long long)value); + return 0; + } + + const double duration = argc > 1 ? strtod(argv[1], NULL) : 4.0; + const double end = monotonic_seconds() + duration; + + while (monotonic_seconds() < end) { + value = work_a(value); + value = work_b(value); + } + + printf("%llu\n", (unsigned long long)value); + return 0; +} diff --git a/macos/dune b/macos/dune new file mode 100644 index 000000000..4605d449c --- /dev/null +++ b/macos/dune @@ -0,0 +1,35 @@ +(library + (name magic_trace_macos_lib) + (wrapped false) + (modules magic_trace_macos_lib mock_processor_trace) + (libraries unix)) + +(executable + (name magic_trace_macos) + (modules magic_trace_macos) + (libraries unix magic_trace_macos_lib)) + +(executable + (name benchmark_overhead) + (modules benchmark_overhead) + (libraries unix magic_trace_macos_lib)) + +(executable + (name mock_processor_trace_cli) + (modules mock_processor_trace_cli) + (libraries unix magic_trace_macos_lib)) + +(executable + (name benchmark_mock_processor_trace) + (modules benchmark_mock_processor_trace) + (libraries unix magic_trace_macos_lib)) + +(test + (name test_magic_trace_macos) + (modules test_magic_trace_macos) + (libraries unix magic_trace_macos_lib)) + +(test + (name test_mock_processor_trace) + (modules test_mock_processor_trace) + (libraries unix magic_trace_macos_lib)) diff --git a/macos/magic_trace_macos.ml b/macos/magic_trace_macos.ml new file mode 100644 index 000000000..640d4b706 --- /dev/null +++ b/macos/magic_trace_macos.ml @@ -0,0 +1,146 @@ +open Magic_trace_macos_lib + +type recording_options = + { duration : string + ; output : string + ; keep_recording : string option + ; force : bool + } + +let default_recording_options = + { duration = "5s" + ; output = "trace.json.gz" + ; keep_recording = None + ; force = false + } + +let usage () = + Printf.printf + {|Experimental magic-trace backend for Apple Silicon Macs. + +Usage: + magic_trace_macos run [OPTIONS] -- COMMAND [ARGUMENTS...] + magic_trace_macos attach -pid PID [OPTIONS] + magic_trace_macos convert PROFILE.xml [-output TRACE.json.gz] [--force] + +Recording options: + -duration, --duration TIME Recording duration (default: 5s) + -output, --output FILE Output trace (default: trace.json.gz) + --keep-recording FILE.trace Keep the Instruments recording + --force Replace an existing output trace + +This backend uses Xcode's 1 ms Time Profiler samples. Function boundaries in +the resulting trace are estimates; short calls may not appear. +|}; + exit 0 + +let option_value name = function + | value :: rest -> value, rest + | [] -> failf "missing value for %s" name + +let rec parse_recording_options options = function + | ("-duration" | "--duration") as name :: rest -> + let value, rest = option_value name rest in + parse_recording_options { options with duration = value } rest + | ("-output" | "--output") as name :: rest -> + let value, rest = option_value name rest in + parse_recording_options { options with output = value } rest + | "--keep-recording" as name :: rest -> + let value, rest = option_value name rest in + parse_recording_options { options with keep_recording = Some value } rest + | "--force" :: rest -> parse_recording_options { options with force = true } rest + | rest -> options, rest + +let run arguments = + let options, rest = parse_recording_options default_recording_options arguments in + let command = + match rest with + | "--" :: command -> command + | command -> command + in + if command = [] then failf "missing command after --"; + record_and_convert + ~duration:options.duration + ~output:options.output + ~keep_recording:options.keep_recording + ~force:options.force + ~target:(Command command) + +let attach arguments = + let rec parse pid options arguments = + match arguments with + | ("-pid" | "--pid") as name :: rest -> + let value, rest = option_value name rest in + let pid = + match int_of_string_opt value with + | Some pid when pid > 0 -> pid + | _ -> failf "invalid pid: %s" value + in + parse (Some pid) options rest + | ("-duration" | "--duration") as name :: rest -> + let value, rest = option_value name rest in + parse pid { options with duration = value } rest + | ("-output" | "--output") as name :: rest -> + let value, rest = option_value name rest in + parse pid { options with output = value } rest + | "--keep-recording" as name :: rest -> + let value, rest = option_value name rest in + parse pid { options with keep_recording = Some value } rest + | "--force" :: rest -> parse pid { options with force = true } rest + | [] -> pid, options + | option :: _ -> failf "unknown attach option: %s" option + in + let pid, options = parse None default_recording_options arguments in + let pid = + match pid with + | Some pid -> pid + | None -> failf "attach requires -pid PID" + in + record_and_convert + ~duration:options.duration + ~output:options.output + ~keep_recording:options.keep_recording + ~force:options.force + ~target:(Pid pid) + +let convert arguments = + let rec parse profile_xml output force = function + | ("-output" | "--output") as name :: rest -> + let value, rest = option_value name rest in + parse profile_xml value force rest + | "--force" :: rest -> parse profile_xml output true rest + | value :: rest when not (String.starts_with ~prefix:"-" value) -> + (match profile_xml with + | None -> parse (Some value) output force rest + | Some _ -> failf "unexpected convert argument: %s" value) + | option :: _ -> failf "unknown convert option: %s" option + | [] -> profile_xml, output, force + in + let profile_xml, output, force = parse None "trace.json.gz" false arguments in + let profile_xml = + match profile_xml with + | Some path -> path + | None -> failf "convert requires an exported time-profile XML file" + in + convert_export ~profile_xml ~output ~force + +let main () = + match Array.to_list Sys.argv with + | _ :: ("-help" | "--help" | "help") :: _ -> usage () + | _ :: "run" :: arguments -> run arguments + | _ :: "attach" :: arguments -> attach arguments + | _ :: "convert" :: arguments -> convert arguments + | _ -> failf "expected run, attach, or convert; pass --help for usage" + +let () = + try main () with + | Error message -> + Printf.eprintf "magic-trace-macos: error: %s\n%!" message; + exit 1 + | Unix.Unix_error (error, function_name, argument) -> + Printf.eprintf + "magic-trace-macos: error: %s(%s): %s\n%!" + function_name + argument + (Unix.error_message error); + exit 1 diff --git a/macos/magic_trace_macos_lib.ml b/macos/magic_trace_macos_lib.ml new file mode 100644 index 000000000..a325231e4 --- /dev/null +++ b/macos/magic_trace_macos_lib.ml @@ -0,0 +1,1051 @@ +exception Error of string + +let failf format = Printf.ksprintf (fun message -> raise (Error message)) format + +type frame = + { name : string + ; binary_name : string + ; binary_path : string + ; address : string + } + +type sample = + { time_ns : int64 + ; weight_ns : int64 + ; pid : int + ; process_name : string + ; tid : int + ; thread_name : string + ; frames_leaf_first : frame list + } + +type interval = + { start_ns : int64 + ; end_ns : int64 + ; pid : int + ; tid : int + ; depth : int + ; frame : frame + } + +type trace_document = + { sample_count : int + ; sampling_period_ns : int64 + ; intervals : interval list + ; processes : (int * string) list + ; threads : ((int * int) * string) list + } + +type target = + | Pid of int + | Command of string list + +module Xml = struct + type element = + { tag : string + ; attributes : (string * string) list + ; text : string + ; children : element list + } + + type parser = + { input : string + ; length : int + ; mutable position : int + } + + let is_space = function + | ' ' | '\t' | '\r' | '\n' -> true + | _ -> false + + let starts_with parser prefix = + let prefix_length = String.length prefix in + parser.position + prefix_length <= parser.length + && String.sub parser.input parser.position prefix_length = prefix + + let skip_spaces parser = + while + parser.position < parser.length && is_space parser.input.[parser.position] + do + parser.position <- parser.position + 1 + done + + let expect_char parser expected = + if + parser.position >= parser.length + || not (Char.equal parser.input.[parser.position] expected) + then + failf "invalid XML at byte %d: expected %C" parser.position expected; + parser.position <- parser.position + 1 + + let consume parser text = + if not (starts_with parser text) then + failf "invalid XML at byte %d: expected %s" parser.position text; + parser.position <- parser.position + String.length text + + let substring_until parser delimiter = + let delimiter_length = String.length delimiter in + let rec search index = + if index + delimiter_length > parser.length then + failf "unterminated XML construct beginning at byte %d" parser.position + else if String.sub parser.input index delimiter_length = delimiter then + index + else + search (index + 1) + in + let finish = search parser.position in + let result = String.sub parser.input parser.position (finish - parser.position) in + parser.position <- finish + delimiter_length; + result + + let add_utf8 buffer codepoint = + if codepoint <= 0x7f then + Buffer.add_char buffer (Char.chr codepoint) + else if codepoint <= 0x7ff then ( + Buffer.add_char buffer (Char.chr (0xc0 lor (codepoint lsr 6))); + Buffer.add_char buffer (Char.chr (0x80 lor (codepoint land 0x3f)))) + else if codepoint <= 0xffff then ( + Buffer.add_char buffer (Char.chr (0xe0 lor (codepoint lsr 12))); + Buffer.add_char buffer (Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f))); + Buffer.add_char buffer (Char.chr (0x80 lor (codepoint land 0x3f)))) + else if codepoint <= 0x10ffff then ( + Buffer.add_char buffer (Char.chr (0xf0 lor (codepoint lsr 18))); + Buffer.add_char buffer (Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f))); + Buffer.add_char buffer (Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f))); + Buffer.add_char buffer (Char.chr (0x80 lor (codepoint land 0x3f)))) + else + failf "invalid Unicode code point in XML entity: %d" codepoint + + let decode_entities text = + let buffer = Buffer.create (String.length text) in + let length = String.length text in + let rec loop position = + if position >= length then + Buffer.contents buffer + else if not (Char.equal text.[position] '&') then ( + Buffer.add_char buffer text.[position]; + loop (position + 1)) + else ( + let rec find_semicolon index = + if index >= length then failf "unterminated XML entity"; + if Char.equal text.[index] ';' then index else find_semicolon (index + 1) + in + let finish = find_semicolon (position + 1) in + let entity = String.sub text (position + 1) (finish - position - 1) in + (match entity with + | "amp" -> Buffer.add_char buffer '&' + | "lt" -> Buffer.add_char buffer '<' + | "gt" -> Buffer.add_char buffer '>' + | "quot" -> Buffer.add_char buffer '"' + | "apos" -> Buffer.add_char buffer '\'' + | _ when String.length entity > 1 && Char.equal entity.[0] '#' -> + let codepoint = + try + if + String.length entity > 2 + && (Char.equal entity.[1] 'x' || Char.equal entity.[1] 'X') + then + int_of_string ("0x" ^ String.sub entity 2 (String.length entity - 2)) + else + int_of_string (String.sub entity 1 (String.length entity - 1)) + with + | Failure _ -> failf "invalid numeric XML entity: &%s;" entity + in + add_utf8 buffer codepoint + | _ -> failf "unsupported XML entity: &%s;" entity); + loop (finish + 1)) + in + loop 0 + + let parse_name parser = + let start = parser.position in + while + parser.position < parser.length + && + match parser.input.[parser.position] with + | ' ' | '\t' | '\r' | '\n' | '/' | '>' | '=' | '?' -> false + | _ -> true + do + parser.position <- parser.position + 1 + done; + if parser.position = start then failf "expected XML name at byte %d" start; + String.sub parser.input start (parser.position - start) + + let parse_attribute_value parser = + if parser.position >= parser.length then failf "missing XML attribute value"; + let quote = parser.input.[parser.position] in + if not (Char.equal quote '"' || Char.equal quote '\'') then + failf "expected quoted XML attribute at byte %d" parser.position; + parser.position <- parser.position + 1; + let start = parser.position in + while + parser.position < parser.length + && not (Char.equal parser.input.[parser.position] quote) + do + parser.position <- parser.position + 1 + done; + if parser.position >= parser.length then failf "unterminated XML attribute value"; + let encoded = String.sub parser.input start (parser.position - start) in + parser.position <- parser.position + 1; + decode_entities encoded + + let rec skip_misc parser = + skip_spaces parser; + if starts_with parser ""); + skip_misc parser) + else if starts_with parser ""); + skip_misc parser) + else if starts_with parser ""); + skip_misc parser) + + let rec parse_element parser = + expect_char parser '<'; + if starts_with parser "/" then failf "unexpected XML closing tag"; + let tag = parse_name parser in + let rec parse_attributes reversed = + skip_spaces parser; + if starts_with parser "/>" then ( + consume parser "/>"; + `Closed (List.rev reversed)) + else if starts_with parser ">" then ( + consume parser ">"; + `Open (List.rev reversed)) + else + let name = parse_name parser in + skip_spaces parser; + expect_char parser '='; + skip_spaces parser; + let value = parse_attribute_value parser in + parse_attributes ((name, value) :: reversed) + in + match parse_attributes [] with + | `Closed attributes -> { tag; attributes; text = ""; children = [] } + | `Open attributes -> + let text = Buffer.create 32 in + let rec parse_contents reversed_children = + if parser.position >= parser.length then + failf "unterminated XML element <%s>" tag + else if starts_with parser ", found " tag closing_tag; + skip_spaces parser; + expect_char parser '>'; + { tag + ; attributes + ; text = decode_entities (Buffer.contents text) + ; children = List.rev reversed_children + }) + else if starts_with parser ""); + parse_contents reversed_children) + else if starts_with parser ""); + parse_contents reversed_children) + else if starts_with parser ""); + parse_contents reversed_children) + else if starts_with parser "<" then + let child = parse_element parser in + parse_contents (child :: reversed_children) + else ( + Buffer.add_char text parser.input.[parser.position]; + parser.position <- parser.position + 1; + parse_contents reversed_children) + in + parse_contents [] + + let parse_string input = + let parser = { input; length = String.length input; position = 0 } in + skip_misc parser; + let root = parse_element parser in + skip_misc parser; + if parser.position <> parser.length then + failf "unexpected XML content at byte %d" parser.position; + root + + let read_file path = + let channel = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> + let length = in_channel_length channel in + really_input_string channel length) + + let parse_file path = parse_string (read_file path) + let attribute element name = List.assoc_opt name element.attributes +end + +module Resolver = struct + type t = + { ids : (string, Xml.element) Hashtbl.t + ; mutable previous_columns : Xml.element option list + } + + let create () = { ids = Hashtbl.create 1024; previous_columns = [] } + + let rec register_subtree resolver element = + (match Xml.attribute element "id" with + | Some identifier -> Hashtbl.replace resolver.ids identifier element + | None -> ()); + List.iter (register_subtree resolver) element.Xml.children + + let resolve resolver element = + let rec loop seen current = + match Xml.attribute current "ref" with + | None -> current + | Some reference -> + if List.mem reference seen then failf "cycle in xctrace XML references"; + let referenced = + match Hashtbl.find_opt resolver.ids reference with + | Some element -> element + | None -> failf "xctrace XML refers to unknown id %s" reference + in + loop (reference :: seen) referenced + in + loop [] element + + let row_columns resolver row = + let rec loop index previous reversed = function + | [] -> + let columns = List.rev reversed in + resolver.previous_columns <- columns; + columns + | encoded :: rest -> + let value = + if String.equal encoded.Xml.tag "sentinel" then + (match List.nth_opt previous index with + | Some value -> value + | None -> None) + else ( + register_subtree resolver encoded; + Some (resolve resolver encoded)) + in + loop (index + 1) previous (value :: reversed) rest + in + loop 0 resolver.previous_columns [] row.Xml.children + + let child resolver element tags = + match element with + | None -> None + | Some element -> + let parent = resolve resolver element in + List.find_map + (fun child -> + let child = resolve resolver child in + if List.mem child.Xml.tag tags then Some child else None) + parent.Xml.children + + let children resolver element tag = + match element with + | None -> [] + | Some element -> + let parent = resolve resolver element in + List.filter_map + (fun child -> + let child = resolve resolver child in + if String.equal child.Xml.tag tag then Some child else None) + parent.Xml.children +end + +let trim = String.trim + +let integer64 ?(default = 0L) = function + | None -> default + | Some element -> + (match Int64.of_string_opt (trim element.Xml.text) with + | Some value -> value + | None -> default) + +let integer ?(default = 0) element = + let value = integer64 ~default:(Int64.of_int default) element in + if + Int64.compare value (Int64.of_int max_int) > 0 + || Int64.compare value (Int64.of_int min_int) < 0 + then + default + else + Int64.to_int value + +let formatted = function + | None -> "" + | Some element -> + (match Xml.attribute element "fmt" with + | Some value -> value + | None -> trim element.Xml.text) + +let all_digits value = + String.length value > 0 + && + let rec loop index = + index = String.length value + || (Char.code value.[index] >= Char.code '0' + && Char.code value.[index] <= Char.code '9' + && loop (index + 1)) + in + loop 0 + +let drop_process_pid_suffix value = + let value = trim value in + match String.rindex_opt value '(' with + | None -> value + | Some opening -> + let length = String.length value in + if + opening > 0 + && Char.equal value.[opening - 1] ' ' + && Char.equal value.[length - 1] ')' + then + let inside = String.sub value (opening + 1) (length - opening - 2) in + if all_digits inside then trim (String.sub value 0 (opening - 1)) else value + else + value + +let drop_thread_process_suffix value = + let value = trim value in + match String.rindex_opt value '(' with + | None -> value + | Some opening -> + let length = String.length value in + let suffix = String.sub value opening (length - opening) in + let contains_pid = + let needle = ", pid: " in + let needle_length = String.length needle in + let rec search index = + index + needle_length <= String.length suffix + && (String.sub suffix index needle_length = needle || search (index + 1)) + in + search 0 + in + if opening > 0 && contains_pid && Char.equal value.[opening - 1] ' ' then + trim (String.sub value 0 (opening - 1)) + else + value + +let rec elements_named tag element = + let descendants = List.concat_map (elements_named tag) element.Xml.children in + if String.equal element.Xml.tag tag then element :: descendants else descendants + +let parse_time_profile_xml path = + let root = Xml.parse_file path in + let resolver = Resolver.create () in + let samples = ref [] in + List.iter + (fun row -> + let columns = Resolver.row_columns resolver row in + let by_tag = Hashtbl.create (List.length columns) in + List.iter + (function + | None -> () + | Some element -> Hashtbl.replace by_tag element.Xml.tag element) + columns; + let get tag = Hashtbl.find_opt by_tag tag in + let sample_time = get "sample-time" in + let thread = get "thread" in + let process = get "process" in + let weight = get "weight" in + let tagged_backtrace = get "tagged-backtrace" in + match thread, tagged_backtrace with + | Some thread, Some tagged_backtrace -> + let process = + match process with + | Some _ -> process + | None -> Resolver.child resolver (Some thread) [ "process" ] + in + let tid = Resolver.child resolver (Some thread) [ "tid" ] in + let pid = Resolver.child resolver process [ "pid" ] in + let backtrace = + Resolver.child resolver (Some tagged_backtrace) [ "backtrace" ] + in + (match backtrace with + | None -> () + | Some backtrace -> + let frames = + Resolver.children resolver (Some backtrace) "frame" + |> List.map (fun frame -> + let binary = Resolver.child resolver (Some frame) [ "binary" ] in + let attribute element name = + match element with + | None -> "" + | Some element -> Option.value ~default:"" (Xml.attribute element name) + in + let address = Option.value ~default:"" (Xml.attribute frame "addr") in + let name = + match Xml.attribute frame "name" with + | Some name when not (String.equal name "") -> name + | _ when not (String.equal address "") -> address + | _ -> "[unknown]" + in + { name + ; binary_name = attribute binary "name" + ; binary_path = attribute binary "path" + ; address + }) + in + if frames <> [] then + let weight_ns = integer64 ~default:1_000_000L weight in + samples := + { time_ns = integer64 sample_time + ; weight_ns = if Int64.compare weight_ns 1L < 0 then 1L else weight_ns + ; pid = integer pid + ; process_name = + (let name = drop_process_pid_suffix (formatted process) in + if String.equal name "" then "process" else name) + ; tid = integer tid + ; thread_name = + (let name = drop_thread_process_suffix (formatted (Some thread)) in + if String.equal name "" then "thread" else name) + ; frames_leaf_first = frames + } + :: !samples) + | _ -> ()) + (elements_named "row" root); + List.rev !samples + +let rec take count values = + if count <= 0 then + [] + else + match values with + | [] -> [] + | value :: rest -> value :: take (count - 1) rest + +let rec drop count values = + if count <= 0 then + values + else + match values with + | [] -> [] + | _ :: rest -> drop (count - 1) rest + +let common_prefix_length active stack = + let rec loop count active stack = + match active, stack with + | (active_frame, _) :: active_rest, stack_frame :: stack_rest + when active_frame = stack_frame -> loop (count + 1) active_rest stack_rest + | _ -> count + in + loop 0 active stack + +let samples_to_intervals (samples : sample list) = + let groups : ((int * int), sample list) Hashtbl.t = Hashtbl.create 16 in + List.iter + (fun (sample : sample) -> + let key = sample.pid, sample.tid in + let previous = Option.value ~default:[] (Hashtbl.find_opt groups key) in + Hashtbl.replace groups key (sample :: previous)) + samples; + let intervals = ref [] in + Hashtbl.iter + (fun (pid, tid) thread_samples -> + let thread_samples = + List.sort (fun left right -> Int64.compare left.time_ns right.time_ns) thread_samples + in + let active = ref [] in + let active_until_ns = ref 0L in + let close_active keep_prefix end_ns = + let closing = drop keep_prefix !active in + List.iteri + (fun offset (frame, start_ns) -> + if Int64.compare end_ns start_ns > 0 then + intervals := + { start_ns + ; end_ns + ; pid + ; tid + ; depth = keep_prefix + offset + ; frame + } + :: !intervals) + closing; + active := take keep_prefix !active + in + List.iter + (fun sample -> + let stack_root_first = List.rev sample.frames_leaf_first in + let half_weight_ns = Int64.div sample.weight_ns 2L in + let gap_tolerance_ns = + if Int64.compare half_weight_ns 100_000L < 0 + then 100_000L + else half_weight_ns + in + if + !active <> [] + && Int64.compare sample.time_ns (Int64.add !active_until_ns gap_tolerance_ns) + > 0 + then + close_active 0 !active_until_ns; + let common_prefix = common_prefix_length !active stack_root_first in + close_active common_prefix sample.time_ns; + let newly_active = + drop common_prefix stack_root_first + |> List.map (fun frame -> frame, sample.time_ns) + in + active := !active @ newly_active; + let sample_end = Int64.add sample.time_ns sample.weight_ns in + if Int64.compare sample_end !active_until_ns > 0 then + active_until_ns := sample_end) + thread_samples; + if !active <> [] then close_active 0 !active_until_ns) + groups; + List.rev !intervals + +let build_trace_document (samples : sample list) = + if samples = [] then + failf + "Time Profiler produced no symbolicated samples. Try a longer recording or a \ + CPU-bound target."; + let process_names = Hashtbl.create 8 in + let thread_names = Hashtbl.create 16 in + List.iter + (fun (sample : sample) -> + if not (Hashtbl.mem process_names sample.pid) then + Hashtbl.add process_names sample.pid sample.process_name; + let key = sample.pid, sample.tid in + if not (Hashtbl.mem thread_names key) then + Hashtbl.add thread_names key sample.thread_name) + samples; + let processes = + Hashtbl.fold (fun pid name result -> (pid, name) :: result) process_names [] + |> List.sort (fun (left, _) (right, _) -> Int.compare left right) + in + let threads = + Hashtbl.fold (fun key name result -> (key, name) :: result) thread_names [] + |> List.sort (fun ((left_pid, left_tid), _) ((right_pid, right_tid), _) -> + match Int.compare left_pid right_pid with + | 0 -> Int.compare left_tid right_tid + | order -> order) + in + let intervals = + samples_to_intervals samples + |> List.sort (fun left right -> + match Int64.compare left.start_ns right.start_ns with + | 0 -> + let left_duration = Int64.sub left.end_ns left.start_ns in + let right_duration = Int64.sub right.end_ns right.start_ns in + (match Int64.compare right_duration left_duration with + | 0 -> Int.compare left.depth right.depth + | order -> order) + | order -> order) + in + let sampling_period_ns = + let weights = + List.map (fun (sample : sample) -> sample.weight_ns) samples + |> List.sort Int64.compare + in + List.nth weights (List.length weights / 2) + in + { sample_count = List.length samples + ; sampling_period_ns + ; intervals + ; processes + ; threads + } + +let output_json_string channel value = + output_char channel '"'; + String.iter + (fun character -> + match character with + | '"' -> output_string channel "\\\"" + | '\\' -> output_string channel "\\\\" + | '\b' -> output_string channel "\\b" + | '\012' -> output_string channel "\\f" + | '\n' -> output_string channel "\\n" + | '\r' -> output_string channel "\\r" + | '\t' -> output_string channel "\\t" + | character when Char.code character < 0x20 -> + Printf.fprintf channel "\\u%04x" (Char.code character) + | character -> output_char channel character) + value; + output_char channel '"' + +let output_event_separator channel first = + if !first then first := false else output_char channel ',' + +let write_uncompressed_trace document path = + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + output_string channel {|{"displayTimeUnit":"ns","traceEvents":[|}; + let first = ref true in + List.iter + (fun (pid, name) -> + output_event_separator channel first; + Printf.fprintf channel {|{"name":"process_name","ph":"M","pid":%d,"tid":0,"args":{"name":|} pid; + output_json_string channel name; + output_string channel "}}") + document.processes; + List.iter + (fun ((pid, tid), name) -> + output_event_separator channel first; + Printf.fprintf + channel + {|{"name":"thread_name","ph":"M","pid":%d,"tid":%d,"args":{"name":|} + pid + tid; + output_json_string channel name; + output_string channel "}}") + document.threads; + List.iter + (fun interval -> + output_event_separator channel first; + output_string channel {|{"name":|}; + output_json_string channel interval.frame.name; + Printf.fprintf + channel + {|,"cat":"macOS Time Profiler (sampled)","ph":"X","ts":%.3f,"dur":%.3f,"pid":%d,"tid":%d,"args":{"module":|} + (Int64.to_float interval.start_ns /. 1_000.) + (max + (Int64.to_float (Int64.sub interval.end_ns interval.start_ns) /. 1_000.) + 0.001) + interval.pid + interval.tid; + output_json_string channel interval.frame.binary_name; + output_string channel {|,"binary":|}; + output_json_string channel interval.frame.binary_path; + output_string channel {|,"address":|}; + output_json_string channel interval.frame.address; + output_string channel {|,"stack depth":|}; + output_string channel (string_of_int interval.depth); + output_string channel ",\"estimated from samples\":true}"; + output_char channel '}') + document.intervals; + output_string + channel + {|],"metadata":{"source":"Xcode Instruments Time Profiler","implementation":"OCaml","sampling":true,"sampleCount":|}; + output_string channel (string_of_int document.sample_count); + output_string channel {|,"samplingPeriodNs":|}; + output_string channel (Int64.to_string document.sampling_period_ns); + output_string channel {|,"intervalCount":|}; + output_string channel (string_of_int (List.length document.intervals)); + output_string + channel + {|,"warning":"Function boundaries are estimates reconstructed from periodic stack samples; short calls may not appear."}}|}) + +let rec make_directory path = + if String.equal path "" || String.equal path "." || String.equal path "/" then + () + else if Sys.file_exists path then ( + if not (Sys.is_directory path) then failf "%s exists and is not a directory" path) + else ( + make_directory (Filename.dirname path); + Unix.mkdir path 0o755) + +let process_exit_code name = function + | Unix.WEXITED code -> code + | Unix.WSIGNALED signal -> failf "%s was terminated by signal %d" name signal + | Unix.WSTOPPED signal -> failf "%s was stopped by signal %d" name signal + +let wait_for_process ?timeout_seconds name pid = + match timeout_seconds with + | None -> process_exit_code name (snd (Unix.waitpid [] pid)) + | Some timeout_seconds -> + let deadline = Unix.gettimeofday () +. timeout_seconds in + let rec loop () = + match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ when Unix.gettimeofday () < deadline -> + ignore (Unix.select [] [] [] 0.05); + loop () + | 0, _ -> + Unix.kill pid Sys.sigterm; + ignore (Unix.select [] [] [] 0.5); + (match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> + Unix.kill pid Sys.sigkill; + ignore (Unix.waitpid [] pid) + | _ -> ()); + failf "%s exceeded its %.1fs timeout" name timeout_seconds + | _, status -> process_exit_code name status + in + loop () + +let gzip_file source destination = + let output = + Unix.openfile destination [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o644 + in + Fun.protect + ~finally:(fun () -> Unix.close output) + (fun () -> + let arguments = [| "/usr/bin/gzip"; "-c"; source |] in + let pid = + Unix.create_process arguments.(0) arguments Unix.stdin output Unix.stderr + in + match wait_for_process "gzip" pid with + | 0 -> () + | code -> failf "gzip failed with exit code %d" code) + +let write_trace_document document output = + make_directory (Filename.dirname output); + if Filename.check_suffix output ".gz" then ( + let temporary = Filename.temp_file "magic-trace-macos-" ".json" in + Fun.protect + ~finally:(fun () -> if Sys.file_exists temporary then Sys.remove temporary) + (fun () -> + write_uncompressed_trace document temporary; + gzip_file temporary output)) + else + write_uncompressed_trace document output + +let normalize_duration value = + let length = String.length value in + let only_digits text = + String.length text > 0 + && + let rec loop index = + index = String.length text + || + match text.[index] with + | '0' .. '9' -> loop (index + 1) + | _ -> false + in + loop 0 + in + let all_digits = only_digits value in + if all_digits then + value ^ "s" + else + let unit_start = + if Filename.check_suffix value "ms" then length - 2 else length - 1 + in + let valid_unit = + unit_start > 0 + && + match String.sub value unit_start (length - unit_start) with + | "ms" | "s" | "m" | "h" -> true + | _ -> false + in + let numeric = if unit_start > 0 then String.sub value 0 unit_start else "" in + let valid_number = + match String.split_on_char '.' numeric with + | [ whole ] -> only_digits whole + | [ whole; fraction ] -> only_digits whole && only_digits fraction + | _ -> false + in + if valid_unit && valid_number then + value + else + failf "invalid duration %S; use a value such as 5, 5s, 500ms, or 1m" value + +let executable_file path = + Sys.file_exists path + && not (Sys.is_directory path) + && + try + Unix.access path [ Unix.X_OK ]; + true + with + | Unix.Unix_error _ -> false + +let find_on_path executable = + if String.contains executable '/' then + if executable_file executable then Some (Unix.realpath executable) else None + else + let path = Option.value ~default:"" (Sys.getenv_opt "PATH") in + String.split_on_char ':' path + |> List.find_map (fun directory -> + let candidate = Filename.concat directory executable in + if executable_file candidate then Some candidate else None) + +let capture_first_line program arguments = + try + let channel = Unix.open_process_args_in program arguments in + let line = input_line channel |> trim in + match Unix.close_process_in channel with + | Unix.WEXITED 0 -> Some line + | _ -> None + with + | End_of_file | Sys_error _ | Unix.Unix_error _ -> None + +let find_xctrace () = + let candidates = + [ Sys.getenv_opt "MAGIC_TRACE_XCTRACE" + ; Some "/Applications/Xcode.app/Contents/Developer/usr/bin/xctrace" + ; find_on_path "xctrace" + ] + in + match + List.find_map + (function + | Some candidate when executable_file candidate -> Some candidate + | _ -> None) + candidates + with + | Some path -> path + | None -> + (match capture_first_line "/usr/bin/xcrun" [| "/usr/bin/xcrun"; "--find"; "xctrace" |] with + | Some path when executable_file path -> path + | _ -> + failf + "xctrace was not found. Install Xcode and select it in Xcode > Settings > \ + Locations > Command Line Tools.") + +let run_process ?timeout_seconds arguments = + let arguments = Array.of_list arguments in + let pid = + Unix.create_process arguments.(0) arguments Unix.stdin Unix.stdout Unix.stderr + in + wait_for_process ?timeout_seconds arguments.(0) pid + +let run_checked arguments = + match run_process arguments with + | 0 -> () + | code -> + failf + "command failed with exit code %d: %s" + code + (String.concat " " arguments) + +let file_contains path needle = + let contents = Xml.read_file path in + let needle_length = String.length needle in + let rec search index = + index + needle_length <= String.length contents + && (String.sub contents index needle_length = needle || search (index + 1)) + in + search 0 + +let export_time_profile ~xctrace ~recording ~destination = + let toc = Filename.concat (Filename.dirname destination) "toc.xml" in + run_checked + [ xctrace + ; "export" + ; "--input" + ; recording + ; "--toc" + ; "--output" + ; toc + ; "--quiet" + ]; + if + not + (file_contains toc {|schema="time-profile"|} + || file_contains toc {|schema='time-profile'|}) + then + failf "the recording does not contain a symbolicated time-profile table"; + let xpath = {|/trace-toc/run[@number="1"]/data/table[@schema="time-profile"]|} in + run_checked + [ xctrace + ; "export" + ; "--input" + ; recording + ; "--xpath" + ; xpath + ; "--output" + ; destination + ; "--quiet" + ] + +let resolve_target command = + match command with + | [] -> failf "missing command after --" + | executable :: arguments -> + let executable = + match find_on_path executable with + | Some path -> path + | None -> failf "target executable was not found: %s" executable + in + executable :: arguments + +let record ~timeout_seconds ~target_stdout ~xctrace ~recording ~duration ~target = + let common = + [ xctrace + ; "record" + ; "--template" + ; "Time Profiler" + ; "--time-limit" + ; normalize_duration duration + ; "--output" + ; recording + ; "--no-prompt" + ; "--quiet" + ] + in + let arguments = + match target with + | Pid pid -> common @ [ "--attach"; string_of_int pid ] + | Command command -> + let output_arguments = + match target_stdout with + | None -> [] + | Some path -> [ "--target-stdout"; path ] + in + common @ output_arguments @ [ "--launch"; "--" ] @ resolve_target command + in + let code = run_process ?timeout_seconds arguments in + if code <> 0 && code <> 54 then failf "xctrace failed with exit code %d" code; + if not (Sys.file_exists recording) then failf "xctrace did not create %s" recording + +let ensure_new_output path force = + if Sys.file_exists path && not force then + failf "%s already exists; choose another output or pass --force" path + +let rec remove_tree path = + if Sys.file_exists path then + if Sys.is_directory path then ( + Sys.readdir path + |> Array.iter (fun name -> remove_tree (Filename.concat path name)); + Unix.rmdir path) + else + Sys.remove path + +let with_temporary_directory action = + let path = Filename.temp_file "magic-trace-macos-" "" in + Sys.remove path; + Unix.mkdir path 0o700; + Fun.protect ~finally:(fun () -> remove_tree path) (fun () -> action path) + +let convert_export ~profile_xml ~output ~force = + ensure_new_output output force; + let samples = parse_time_profile_xml profile_xml in + let document = build_trace_document samples in + write_trace_document document output; + Printf.eprintf + "Converted %d samples into %d estimated intervals.\n%!" + document.sample_count + (List.length document.intervals); + Printf.printf "%s\n%!" (Unix.realpath output) + +let record_and_convert ~duration ~output ~keep_recording ~force ~target = + ensure_new_output output force; + let xctrace = find_xctrace () in + with_temporary_directory (fun temporary -> + let recording = + match keep_recording with + | Some path -> path + | None -> Filename.concat temporary "recording.trace" + in + if Sys.file_exists recording then failf "%s already exists" recording; + Printf.eprintf + "Recording sampled stacks for %s with %s...\n%!" + (normalize_duration duration) + xctrace; + record + ~timeout_seconds:None + ~target_stdout:(Some "-") + ~xctrace + ~recording + ~duration + ~target; + let exported_xml = Filename.concat temporary "time-profile.xml" in + Printf.eprintf "Exporting symbolicated samples...\n%!"; + export_time_profile ~xctrace ~recording ~destination:exported_xml; + let samples = parse_time_profile_xml exported_xml in + let document = build_trace_document samples in + write_trace_document document output; + Printf.eprintf + "Wrote %d samples as %d estimated intervals.\n%!" + document.sample_count + (List.length document.intervals); + Printf.printf "%s\n%!" (Unix.realpath output)) diff --git a/macos/magic_trace_macos_lib.mli b/macos/magic_trace_macos_lib.mli new file mode 100644 index 000000000..12cc9be79 --- /dev/null +++ b/macos/magic_trace_macos_lib.mli @@ -0,0 +1,74 @@ +exception Error of string + +val failf : ('a, unit, string, 'b) format4 -> 'a + +type frame = + { name : string + ; binary_name : string + ; binary_path : string + ; address : string + } + +type sample = + { time_ns : int64 + ; weight_ns : int64 + ; pid : int + ; process_name : string + ; tid : int + ; thread_name : string + ; frames_leaf_first : frame list + } + +type interval = + { start_ns : int64 + ; end_ns : int64 + ; pid : int + ; tid : int + ; depth : int + ; frame : frame + } + +type trace_document = + { sample_count : int + ; sampling_period_ns : int64 + ; intervals : interval list + ; processes : (int * string) list + ; threads : ((int * int) * string) list + } + +type target = + | Pid of int + | Command of string list + +val normalize_duration : string -> string +val parse_time_profile_xml : string -> sample list +val samples_to_intervals : sample list -> interval list +val build_trace_document : sample list -> trace_document +val write_trace_document : trace_document -> string -> unit + +val find_on_path : string -> string option +val find_xctrace : unit -> string +val with_temporary_directory : (string -> 'a) -> 'a + +val record + : timeout_seconds:float option + -> target_stdout:string option + -> xctrace:string + -> recording:string + -> duration:string + -> target:target + -> unit + +val convert_export + : profile_xml:string + -> output:string + -> force:bool + -> unit + +val record_and_convert + : duration:string + -> output:string + -> keep_recording:string option + -> force:bool + -> target:target + -> unit diff --git a/macos/mock_processor_trace.ml b/macos/mock_processor_trace.ml new file mode 100644 index 000000000..b5ec080a7 --- /dev/null +++ b/macos/mock_processor_trace.ml @@ -0,0 +1,261 @@ +exception Decode_error of string + +let decode_fail format = + Printf.ksprintf (fun message -> raise (Decode_error message)) format + +type trace = + { packets : bytes + ; event_count : int + ; resolution_ns : int64 + ; anchor_every : int + } + +type interval = + { function_id : int + ; function_name : string + ; start_ns : int64 + ; end_ns : int64 + ; depth : int + } + +type stats = + { event_count : int + ; call_count : int + ; return_count : int + ; anchor_count : int + ; packet_bytes : int + ; virtual_duration_ns : int64 + ; resolution_ns : int64 + ; max_depth : int + ; checksum : int64 + } + +let event_count (trace : trace) = trace.event_count +let packet_bytes (trace : trace) = Bytes.length trace.packets +let resolution_ns (trace : trace) = trace.resolution_ns + +let function_name = function + | 1 -> "main" + | 2 -> "work_a" + | 3 -> "work_b" + | 4 -> "scramble" + | identifier -> Printf.sprintf "function_%d" identifier + +let add_int64_little_endian buffer value = + for shift = 0 to 7 do + let byte = + Int64.(to_int (logand (shift_right_logical value (shift * 8)) 0xffL)) + in + Buffer.add_char buffer (Char.chr byte) + done + +let read_int64_little_endian bytes position = + if position < 0 || position + 8 > Bytes.length bytes then + decode_fail "truncated 64-bit timing anchor at byte %d" position; + let result = ref 0L in + for shift = 0 to 7 do + let byte = Int64.of_int (Char.code (Bytes.get bytes (position + shift))) in + result := Int64.logor !result (Int64.shift_left byte (shift * 8)) + done; + !result + +(* Each cycle is a tiny, known program: + + main + work_a + scramble + work_b + scramble + + Function identifiers 1..14 are call packets and 0 is a return packet. + Two packets fit in one byte. 0xff is reserved for a timing anchor. *) +let cycle_events = [| 1; 2; 4; 0; 0; 3; 4; 0; 0; 0 |] + +let generate ?(resolution_ns = 40L) ?(anchor_every = 4096) ~cycles () = + if cycles <= 0 then invalid_arg "Mock_processor_trace.generate: cycles must be positive"; + if Int64.compare resolution_ns 1L < 0 then + invalid_arg "Mock_processor_trace.generate: resolution_ns must be positive"; + if anchor_every <= 0 || anchor_every mod 2 <> 0 then + invalid_arg + "Mock_processor_trace.generate: anchor_every must be a positive even integer"; + if cycles > max_int / Array.length cycle_events then + invalid_arg "Mock_processor_trace.generate: event count is too large"; + let event_count = cycles * Array.length cycle_events in + let anchor_count = ((event_count - 1) / anchor_every) + 1 in + let capacity = (event_count / 2) + (anchor_count * 9) in + let buffer = Buffer.create capacity in + let event_at index = cycle_events.(index mod Array.length cycle_events) in + let index = ref 0 in + while !index < event_count do + if !index mod anchor_every = 0 then ( + Buffer.add_char buffer '\xff'; + add_int64_little_endian buffer (Int64.mul (Int64.of_int !index) resolution_ns)); + let high = event_at !index in + let low = event_at (!index + 1) in + Buffer.add_char buffer (Char.chr ((high lsl 4) lor low)); + index := !index + 2 + done; + { packets = Bytes.of_string (Buffer.contents buffer) + ; event_count + ; resolution_ns + ; anchor_every + } + +let mix_checksum checksum function_id time_ns depth = + let open Int64 in + let value = + logxor + time_ns + (logor (shift_left (of_int function_id) 48) (shift_left (of_int depth) 40)) + in + add (mul checksum 0x100000001b3L) value + +let decode ?(on_interval = fun _ -> ()) trace = + let packets_length = Bytes.length trace.packets in + let stack_capacity = 16 in + let stack_ids = ref (Array.make stack_capacity 0) in + let stack_starts = ref (Array.make stack_capacity 0L) in + let depth = ref 0 in + let maximum_depth = ref 0 in + let calls = ref 0 in + let returns = ref 0 in + let anchors = ref 0 in + let checksum = ref 0xcbf29ce484222325L in + let position = ref 0 in + let decoded_events = ref 0 in + let current_time_ns = ref 0L in + let grow_stack () = + let old_ids = !stack_ids in + let old_starts = !stack_starts in + let new_length = Array.length old_ids * 2 in + let new_ids = Array.make new_length 0 in + let new_starts = Array.make new_length 0L in + Array.blit old_ids 0 new_ids 0 (Array.length old_ids); + Array.blit old_starts 0 new_starts 0 (Array.length old_starts); + stack_ids := new_ids; + stack_starts := new_starts + in + let decode_event packet = + if !decoded_events >= trace.event_count then + decode_fail "packet stream contains more than %d events" trace.event_count; + if packet = 0 then ( + if !depth = 0 then + decode_fail "return with an empty call stack at event %d" !decoded_events; + let closing_depth = !depth - 1 in + let identifier = (!stack_ids).(closing_depth) in + let start_ns = (!stack_starts).(closing_depth) in + on_interval + { function_id = identifier + ; function_name = function_name identifier + ; start_ns + ; end_ns = !current_time_ns + ; depth = closing_depth + }; + depth := closing_depth; + incr returns; + checksum := mix_checksum !checksum identifier !current_time_ns closing_depth) + else ( + if packet >= 15 then + decode_fail "reserved function identifier %d at event %d" packet !decoded_events; + if !depth = Array.length !stack_ids then grow_stack (); + (!stack_ids).(!depth) <- packet; + (!stack_starts).(!depth) <- !current_time_ns; + checksum := mix_checksum !checksum packet !current_time_ns !depth; + incr depth; + if !depth > !maximum_depth then maximum_depth := !depth; + incr calls); + incr decoded_events; + current_time_ns := Int64.add !current_time_ns trace.resolution_ns + in + while !position < packets_length do + let byte = Char.code (Bytes.get trace.packets !position) in + if byte = 0xff then ( + let anchor = read_int64_little_endian trace.packets (!position + 1) in + let expected_event = !anchors * trace.anchor_every in + if !decoded_events <> expected_event then + decode_fail + "timing anchor %d occurs at event %d, expected event %d" + !anchors + !decoded_events + expected_event; + let expected_time = + Int64.mul (Int64.of_int !decoded_events) trace.resolution_ns + in + if not (Int64.equal anchor expected_time) then + decode_fail + "timing anchor at event %d is %Ld ns, expected %Ld ns" + !decoded_events + anchor + expected_time; + current_time_ns := anchor; + incr anchors; + position := !position + 9) + else ( + decode_event (byte lsr 4); + if !decoded_events < trace.event_count then decode_event (byte land 0x0f); + incr position) + done; + if !decoded_events <> trace.event_count then + decode_fail + "packet stream ended after %d of %d events" + !decoded_events + trace.event_count; + if !depth <> 0 then + decode_fail "packet stream ended with %d unclosed calls" !depth; + { event_count = !decoded_events + ; call_count = !calls + ; return_count = !returns + ; anchor_count = !anchors + ; packet_bytes = packets_length + ; virtual_duration_ns = !current_time_ns + ; resolution_ns = trace.resolution_ns + ; max_depth = !maximum_depth + ; checksum = !checksum + } + +let output_json_string channel value = + output_char channel '"'; + String.iter + (function + | '"' -> output_string channel "\\\"" + | '\\' -> output_string channel "\\\\" + | '\n' -> output_string channel "\\n" + | '\r' -> output_string channel "\\r" + | '\t' -> output_string channel "\\t" + | character -> output_char channel character) + value; + output_char channel '"' + +let write_trace_json ~force trace path = + if Sys.file_exists path && not force then + decode_fail "%s already exists; pass --force to replace it" path; + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> + output_string + channel + {|{"displayTimeUnit":"ns","traceEvents":[{"name":"process_name","ph":"M","pid":1,"tid":0,"args":{"name":"mock-arm64-target"}},{"name":"thread_name","ph":"M","pid":1,"tid":1,"args":{"name":"main"}}|}; + let stats = + decode + ~on_interval:(fun interval -> + output_string channel {|,{"name":|}; + output_json_string channel interval.function_name; + Printf.fprintf + channel + {|,"cat":"Synthetic Processor Trace","ph":"X","ts":%.3f,"dur":%.3f,"pid":1,"tid":1,"args":{"functionId":%d,"stackDepth":%d}}|} + (Int64.to_float interval.start_ns /. 1_000.) + (Int64.to_float (Int64.sub interval.end_ns interval.start_ns) + /. 1_000.) + interval.function_id + interval.depth) + trace + in + Printf.fprintf + channel + {|],"metadata":{"source":"Synthetic Apple Processor Trace performance model","implementation":"OCaml","simulated":true,"sampling":false,"resolutionNs":%Ld,"eventCount":%d,"callCount":%d,"packetBytes":%d,"warning":"This validates decoder throughput and exact reconstruction, not real hardware capture overhead."}}|} + stats.resolution_ns + stats.event_count + stats.call_count + stats.packet_bytes; + stats) diff --git a/macos/mock_processor_trace.mli b/macos/mock_processor_trace.mli new file mode 100644 index 000000000..e3eafaced --- /dev/null +++ b/macos/mock_processor_trace.mli @@ -0,0 +1,48 @@ +exception Decode_error of string + +type trace + +type interval = + { function_id : int + ; function_name : string + ; start_ns : int64 + ; end_ns : int64 + ; depth : int + } + +type stats = + { event_count : int + ; call_count : int + ; return_count : int + ; anchor_count : int + ; packet_bytes : int + ; virtual_duration_ns : int64 + ; resolution_ns : int64 + ; max_depth : int + ; checksum : int64 + } + +(** Generate a deterministic, balanced call trace. + + Two call/return events are packed into every byte. A full 64-bit timing + anchor is inserted every [anchor_every] events, modelling the sparse + timestamp packets used by hardware processor tracing. *) +val generate + : ?resolution_ns:int64 + -> ?anchor_every:int + -> cycles:int + -> unit + -> trace + +val event_count : trace -> int +val packet_bytes : trace -> int +val resolution_ns : trace -> int64 + +(** Decode the packet stream and reconstruct exact function intervals. + [on_interval] is called when a return closes a function. *) +val decode : ?on_interval:(interval -> unit) -> trace -> stats + +(** Write a small synthetic trace that can be opened by Perfetto or + magic-trace.org. Large performance tests should use [decode] instead so + JSON serialization does not dominate the benchmark. *) +val write_trace_json : force:bool -> trace -> string -> stats diff --git a/macos/mock_processor_trace_cli.ml b/macos/mock_processor_trace_cli.ml new file mode 100644 index 000000000..87ecfe281 --- /dev/null +++ b/macos/mock_processor_trace_cli.ml @@ -0,0 +1,100 @@ +open Mock_processor_trace + +let fail format = Printf.ksprintf (fun message -> raise (Invalid_argument message)) format + +let usage () = + Printf.printf + {|Synthetic 40 ns Processor Trace model, implemented in OCaml. + +Usage: + mock_processor_trace_cli [OPTIONS] + +Options: + --cycles N Nested demo cycles (default: 1000) + --resolution-ns N Virtual event spacing (default: 40) + --anchor-every N Events between timing anchors (default: 4096) + --output FILE Perfetto JSON output (default: mock-40ns-trace.json) + --force Replace an existing output + --help Show this help + +The output can be opened at https://ui.perfetto.dev or +https://magic-trace.org. This is a performance model, not a claim that an M1 +can capture real programs at 40 ns. +|}; + exit 0 + +let positive_int name value = + match int_of_string_opt value with + | Some value when value > 0 -> value + | _ -> fail "%s must be a positive integer" name + +let positive_int64 name value = + match Int64.of_string_opt value with + | Some value when Int64.compare value 1L >= 0 -> value + | _ -> fail "%s must be a positive integer" name + +let option_value name = function + | value :: rest -> value, rest + | [] -> fail "missing value for %s" name + +let rec parse cycles resolution_ns anchor_every output force = function + | "--cycles" :: rest -> + let value, rest = option_value "--cycles" rest in + parse (positive_int "--cycles" value) resolution_ns anchor_every output force rest + | "--resolution-ns" :: rest -> + let value, rest = option_value "--resolution-ns" rest in + parse + cycles + (positive_int64 "--resolution-ns" value) + anchor_every + output + force + rest + | "--anchor-every" :: rest -> + let value, rest = option_value "--anchor-every" rest in + parse + cycles + resolution_ns + (positive_int "--anchor-every" value) + output + force + rest + | "--output" :: rest -> + let value, rest = option_value "--output" rest in + parse cycles resolution_ns anchor_every value force rest + | "--force" :: rest -> parse cycles resolution_ns anchor_every output true rest + | ("--help" | "-help" | "-h") :: _ -> usage () + | option :: _ -> fail "unknown option: %s" option + | [] -> cycles, resolution_ns, anchor_every, output, force + +let run () = + let arguments = + match Array.to_list Sys.argv with + | _ :: arguments -> arguments + | [] -> [] + in + let cycles, resolution_ns, anchor_every, output, force = + parse 1_000 40L 4_096 "mock-40ns-trace.json" false arguments + in + let trace = generate ~resolution_ns ~anchor_every ~cycles () in + let stats = write_trace_json ~force trace output in + Printf.printf + "wrote=%s events=%d calls=%d resolution=%Ldns virtual_duration=%.3fms \ + packet_bytes=%d bytes_per_event=%.4f checksum=%Lx\n" + output + stats.event_count + stats.call_count + stats.resolution_ns + (Int64.to_float stats.virtual_duration_ns /. 1_000_000.) + stats.packet_bytes + (float_of_int stats.packet_bytes /. float_of_int stats.event_count) + stats.checksum + +let () = + try run () with + | Invalid_argument message | Decode_error message -> + Printf.eprintf "mock-processor-trace: error: %s\n%!" message; + exit 1 + | Sys_error message -> + Printf.eprintf "mock-processor-trace: error: %s\n%!" message; + exit 1 diff --git a/macos/test_magic_trace_macos.ml b/macos/test_magic_trace_macos.ml new file mode 100644 index 000000000..9782bc39a --- /dev/null +++ b/macos/test_magic_trace_macos.ml @@ -0,0 +1,168 @@ +open Magic_trace_macos_lib + +let time_profile_xml = + {| + + + + + 1000000 + + 291 + 42 + + + 1 + Running + 1000000 + + + + + + + + + + + 2000000 + + + + + + + + + + + + + + 10000000 + + + + + + + + + +|} + +let fail format = Printf.ksprintf (fun message -> failwith message) format + +let check condition format = + Printf.ksprintf (fun message -> if not condition then failwith message) format + +let check_equal_int expected actual label = + check (expected = actual) "%s: expected %d, got %d" label expected actual + +let check_equal_int64 expected actual label = + check + (Int64.equal expected actual) + "%s: expected %Ld, got %Ld" + label + expected + actual + +let with_temp_file contents action = + let path = Filename.temp_file "magic-trace-macos-test-" ".xml" in + let channel = open_out_bin path in + output_string channel contents; + close_out channel; + Fun.protect ~finally:(fun () -> Sys.remove path) (fun () -> action path) + +let parsed_samples () = with_temp_file time_profile_xml parse_time_profile_xml + +let test_duration () = + check + (String.equal (normalize_duration "5") "5s") + "bare duration was not normalized"; + check + (String.equal (normalize_duration "500ms") "500ms") + "explicit duration unit changed"; + match normalize_duration "soon" with + | _ -> fail "invalid duration was accepted" + | exception Error _ -> () + +let test_parser () = + let samples = parsed_samples () in + check_equal_int 3 (List.length samples) "sample count"; + let first = List.hd samples in + check_equal_int 42 first.pid "pid"; + check_equal_int 291 first.tid "tid"; + check (String.equal first.process_name "target") "unexpected process name"; + check + (String.equal first.thread_name "Main Thread (0x123)") + "unexpected thread name"; + check + (String.equal (List.hd first.frames_leaf_first).name "leaf_a") + "XML entities were not decoded"; + let second = List.nth samples 1 in + check + (List.map (fun frame -> frame.name) second.frames_leaf_first = [ "leaf_b"; "root" ]) + "frame references were not resolved" + +let test_intervals () = + let intervals = parsed_samples () |> samples_to_intervals in + let named name = List.filter (fun interval -> String.equal interval.frame.name name) intervals in + let root = named "root" in + check_equal_int 2 (List.length root) "root interval count"; + let first_root = List.hd root in + check_equal_int64 1_000_000L first_root.start_ns "root start"; + check_equal_int64 3_000_000L first_root.end_ns "root end"; + check_equal_int 1 (List.length (named "leaf_a")) "leaf_a interval count"; + check_equal_int 2 (List.length (named "leaf_b")) "leaf_b interval count" + +let file_contains path needle = + let channel = open_in_bin path in + let contents = + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> really_input_string channel (in_channel_length channel)) + in + let needle_length = String.length needle in + let rec search index = + index + needle_length <= String.length contents + && (String.sub contents index needle_length = needle || search (index + 1)) + in + search 0 + +let test_json () = + let document = parsed_samples () |> build_trace_document in + check_equal_int 3 document.sample_count "document sample count"; + check_equal_int64 + 1_000_000L + document.sampling_period_ns + "document sampling period"; + let output = Filename.temp_file "magic-trace-macos-test-" ".json" in + Fun.protect + ~finally:(fun () -> Sys.remove output) + (fun () -> + write_trace_document document output; + check (file_contains output {|"implementation":"OCaml"|}) "OCaml metadata missing"; + check (file_contains output {|"name":"leaf_a"|}) "duration event missing"; + check + (not (file_contains output {|true}}}|})) + "duration event contains an extra closing brace") + +let tests = + [ "duration", test_duration + ; "xctrace XML parser", test_parser + ; "sample interval reconstruction", test_intervals + ; "Chrome trace JSON writer", test_json + ] + +let () = + List.iter + (fun (name, test) -> + try + test (); + Printf.printf "ok - %s\n%!" name + with + | error -> + Printf.eprintf "not ok - %s: %s\n%!" name (Printexc.to_string error); + exit 1) + tests diff --git a/macos/test_mock_processor_trace.ml b/macos/test_mock_processor_trace.ml new file mode 100644 index 000000000..f40127a78 --- /dev/null +++ b/macos/test_mock_processor_trace.ml @@ -0,0 +1,91 @@ +open Mock_processor_trace + +let check condition format = + Printf.ksprintf (fun message -> if not condition then failwith message) format + +let check_int expected actual label = + check (expected = actual) "%s: expected %d, got %d" label expected actual + +let check_int64 expected actual label = + check + (Int64.equal expected actual) + "%s: expected %Ld, got %Ld" + label + expected + actual + +let test_exact_reconstruction () = + let trace = generate ~resolution_ns:40L ~anchor_every:4 ~cycles:2 () in + let intervals = ref [] in + let stats = decode ~on_interval:(fun interval -> intervals := interval :: !intervals) trace in + check_int 20 stats.event_count "event count"; + check_int 10 stats.call_count "call count"; + check_int 10 stats.return_count "return count"; + check_int 5 stats.anchor_count "anchor count"; + check_int 3 stats.max_depth "maximum depth"; + check_int64 800L stats.virtual_duration_ns "virtual duration"; + let repeated_stats = decode trace in + check_int64 stats.checksum repeated_stats.checksum "deterministic checksum"; + let intervals = List.rev !intervals in + let first_named name = + match List.find_opt (fun interval -> String.equal interval.function_name name) intervals with + | Some interval -> interval + | None -> failwith ("missing interval " ^ name) + in + let main = first_named "main" in + check_int64 0L main.start_ns "main start"; + check_int64 360L main.end_ns "main end"; + check_int 0 main.depth "main depth"; + let work_a = first_named "work_a" in + check_int64 40L work_a.start_ns "work_a start"; + check_int64 160L work_a.end_ns "work_a end"; + let scramble = first_named "scramble" in + check_int64 80L scramble.start_ns "scramble start"; + check_int64 120L scramble.end_ns "scramble end" + +let file_contains path needle = + let channel = open_in_bin path in + let contents = + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> really_input_string channel (in_channel_length channel)) + in + let needle_length = String.length needle in + let rec search index = + index + needle_length <= String.length contents + && (String.sub contents index needle_length = needle || search (index + 1)) + in + search 0 + +let test_json_output () = + let trace = generate ~cycles:1 () in + let path = Filename.temp_file "magic-trace-mock-" ".json" in + Sys.remove path; + Fun.protect + ~finally:(fun () -> if Sys.file_exists path then Sys.remove path) + (fun () -> + let stats = write_trace_json ~force:false trace path in + check_int 10 stats.event_count "JSON event count"; + check (file_contains path {|"simulated":true|}) "simulated marker missing"; + check (file_contains path {|"resolutionNs":40|}) "40 ns resolution missing"; + check (file_contains path {|"name":"work_a"|}) "work_a interval missing"; + match write_trace_json ~force:false trace path with + | _ -> failwith "existing output was replaced without --force" + | exception Decode_error _ -> ()) + +let tests = + [ "exact 40 ns reconstruction", test_exact_reconstruction + ; "Perfetto JSON output", test_json_output + ] + +let () = + List.iter + (fun (name, test) -> + try + test (); + Printf.printf "ok - %s\n%!" name + with + | error -> + Printf.eprintf "not ok - %s: %s\n%!" name (Printexc.to_string error); + exit 1) + tests