From a829cc5d2b29fc1c115b872883ac603289ca45e6 Mon Sep 17 00:00:00 2001 From: Josiah White Date: Sat, 7 Jun 2025 20:05:00 -0500 Subject: [PATCH 1/5] Add support for ptwrite events Signed-off-by: Josiah White --- src/event.ml | 4 ++ src/event.mli | 4 ++ src/for_range.ml | 6 ++- src/perf_capabilities.ml | 15 +++++++ src/perf_capabilities.mli | 1 + src/perf_decode.ml | 88 ++++++++++++++++++++++++++++++++++++++- src/perf_tool_backend.ml | 60 +++++++++++++++----------- src/trace.ml | 5 ++- src/trace_writer.ml | 27 +++++++++++- 9 files changed, 180 insertions(+), 30 deletions(-) diff --git a/src/event.ml b/src/event.ml index 24694485c..e3c653361 100644 --- a/src/event.ml +++ b/src/event.ml @@ -83,6 +83,10 @@ module Ok = struct ; count : int ; name : Collection_mode.Event.Name.t } + | Ptwrite of + { location : Location.t + ; data : string + } [@@deriving sexp, bin_io] end diff --git a/src/event.mli b/src/event.mli index 929854d07..b906c3118 100644 --- a/src/event.mli +++ b/src/event.mli @@ -55,6 +55,10 @@ module Ok : sig ; count : int ; name : Collection_mode.Event.Name.t } (** Represents counter based events collected through sampling. *) + | Ptwrite of + { location : Location.t + ; data : string + } (** Represents ptwrite events collected through Intel PT using PTWRITE. *) [@@deriving sexp] end diff --git a/src/for_range.ml b/src/for_range.ml index 1ac527726..b0c212e9b 100644 --- a/src/for_range.ml +++ b/src/for_range.ml @@ -25,7 +25,10 @@ let range_hit_times ~decode_events ~range_symbols = let is_start symbol = String.(Symbol.display_name symbol = start_symbol) in let is_stop symbol = String.(Symbol.display_name symbol = stop_symbol) in Pipe.filter_map events ~f:(function - | Error _ | Ok { data = Power _; _ } | Ok { data = Event_sample _; _ } -> None + | Error _ + | Ok { data = Power _; _ } + | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } -> None | Ok { data = Trace trace; time; _ } -> (match trace.kind with | Some Call -> @@ -93,6 +96,7 @@ let decode_events_and_annotate ~decode_events ~range_symbols = | Ok { data = Power _; _ } | Ok { data = Stacktrace_sample _; _ } | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } | Error _ -> hits, in_filtered_region) in ( (hits, in_filtered_region) diff --git a/src/perf_capabilities.ml b/src/perf_capabilities.ml index 269b97fef..8022d871a 100644 --- a/src/perf_capabilities.ml +++ b/src/perf_capabilities.ml @@ -8,6 +8,7 @@ let kcore = bit 2 let snapshot_on_exit = bit 3 let last_branch_record = bit 4 let dlfilter = bit 5 +let ptwrite = bit 6 include Flags.Make (struct let allow_intersecting = false @@ -20,6 +21,7 @@ include Flags.Make (struct ; kcore, "kcore" ; last_branch_record, "last_branch_record" ; dlfilter, "dlfilter" + ; ptwrite, "ptwrite" ] ;; end) @@ -56,6 +58,18 @@ let supports_configurable_psb_period () = | Sys_error _ -> false ;; +let supports_ptwrite () = + try + let ptwrite_cap = + In_channel.read_all "/sys/bus/event_source/devices/intel_pt/caps/ptwrite" + in + String.( = ) ptwrite_cap "1\n" + with + (* Even if this file is not present (i.e. when Intel PT isn't present), we + don't want capability checking to fail. *) + | Sys_error _ -> false +;; + (* This checks if pdcm flag is present in /proc/cpuinfo. This is necessary for LBR to work. Although I couldn't ascertain that it is also sufficient. However it seems unlikely this would fail on most machines. *) @@ -108,6 +122,7 @@ let detect_exn () = let set_if bool flag cap = cap + if bool then flag else empty in empty |> set_if (supports_configurable_psb_period ()) configurable_psb_period + |> set_if (supports_ptwrite ()) ptwrite |> set_if (supports_tracing_kernel ()) kernel_tracing |> set_if (supports_kcore version) kcore |> set_if (supports_snapshot_on_exit version) snapshot_on_exit diff --git a/src/perf_capabilities.mli b/src/perf_capabilities.mli index 2a2d6a214..828df839e 100644 --- a/src/perf_capabilities.mli +++ b/src/perf_capabilities.mli @@ -11,4 +11,5 @@ val kcore : t val snapshot_on_exit : t val last_branch_record : t val dlfilter : t +val ptwrite : t val detect_exn : unit -> t Deferred.t diff --git a/src/perf_decode.ml b/src/perf_decode.ml index 28480f4cc..3eb2e4170 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -29,6 +29,12 @@ let perf_cbr_event_re = Re.Perl.re {|^ *([a-z )(]*)? +cbr: +([0-9]+ +freq: +([0-9]+) MHz)?(.*)$|} |> Re.compile ;; +let perf_ptwrite_event_re = + Re.Perl.re + {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +(0x[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} + |> Re.compile +;; + let trace_error_re = Re.Posix.re {|^ instruction trace error type [0-9]+ (time ([0-9]+)\.([0-9]+) )?cpu [\-0-9]+ pid ([\-0-9]+) tid ([\-0-9]+) ip (0x[0-9a-fA-F]+|0) code [0-9]+: (.*)$|} @@ -44,7 +50,15 @@ type header = { thread : Event.Thread.t ; time : Time_ns.Span.t ; period : int - ; event : [ `Branches | `Cbr | `Psb | `Cycles | `Branch_misses | `Cache_misses ] + ; event : + [ `Branches + | `Cbr + | `Psb + | `Cycles + | `Branch_misses + | `Cache_misses + | `Ptwrite + ] ; remaining_line : string } @@ -96,6 +110,7 @@ let parse_event_header line = | "cycles" -> `Cycles | "branch-misses" -> `Branch_misses | "cache-misses" -> `Cache_misses + | "ptwrite" -> `Ptwrite | _ -> raise_s [%message @@ -328,6 +343,33 @@ let parse_perf_extra_sampled_event } ;; +let parse_perf_ptwrite_event ?perf_maps (thread : Event.Thread.t) time line : Event.t = + match Re.Group.all (Re.exec perf_ptwrite_event_re line) with + | [| _ + ; _branch_kind + ; _fup_ip + ; payload + ; _payload_ascii + ; _unknown + ; instruction_pointer + ; symbol_and_offset + |] -> + let location = + parse_location ?perf_maps ~pid:thread.pid instruction_pointer symbol_and_offset + in + Ok + { thread + ; time + ; data = Ptwrite { location; data = payload } + ; in_transaction = false + } + | results -> + raise_s + [%message + "Regex of perf ptwrite event did not match expected fields" + (results : string array)] +;; + let to_event ?perf_maps lines : Event.t option = try match lines with @@ -364,7 +406,9 @@ let to_event ?perf_maps lines : Event.t option = period remaining_line lines - Cache_misses))) + Cache_misses) + | `Ptwrite -> + Some (parse_perf_ptwrite_event ?perf_maps thread time remaining_line))) with | exn -> raise_s @@ -725,6 +769,46 @@ let%test_module _ = (Trace (trace_state_change End) (kind Async) (src 0x7f6fce0b71f4) (dst 0x0)))))) |}] ;; + + let%expect_test "perf ptwrite event" = + check + {| 2769074/2769293 2592496.569782106: 1 ptwrite: call IP: 0 payload: 0x1b5 0 55c7952ad2d0 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (2769074)) (tid (2769293)))) (time 30d8m16.569782106s) + (data (Ptwrite (location 0x55c7952ad2d0) (data 0x1b5)))))) |}] + ;; + + let%expect_test "perf ptwrite event with printable payload" = + check + {|2817453/2817483 2596547.813541321: 1 ptwrite: call IP: 0 payload: 0x62 b 0 613d946b42d0 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (2817453)) (tid (2817483)))) (time 30d1h15m47.813541321s) + (data (Ptwrite (location 0x613d946b42d0) (data 0x62)))))) |}] + ;; + + let%expect_test "perf ptwrite event with jcc instruction" = + check + {|3256341/3256760 2632746.069047397: 1 ptwrite: jcc IP: 0 payload: 0x5000000000061b2 0 577bcad80555 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (3256341)) (tid (3256760)))) (time 30d11h19m6.069047397s) + (data (Ptwrite (location 0x577bcad80555) (data 0x5000000000061b2)))))) |}] + ;; + + let%expect_test "perf ptwrite event without instruction" = + check + {|3285832/3286108 2634666.172476558: 1 ptwrite: IP: 0 payload: 0xa00000000000000 0 64d20fb10432 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (3285832)) (tid (3286108)))) (time 30d11h51m6.172476558s) + (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) |}] + ;; end) ;; diff --git a/src/perf_tool_backend.ml b/src/perf_tool_backend.ml index ce10634b4..f74e25c46 100644 --- a/src/perf_tool_backend.ml +++ b/src/perf_tool_backend.ml @@ -117,29 +117,41 @@ module Recording = struct Timer_resolution.Low | _, _ -> timer_resolution in - match timer_resolution with - | Low -> Or_error.return "" - | Normal -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0" - | High -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0,noretcomp=1" - | Sample _ -> - Or_error.error_string - "[-timer-resolution Sample] can only be used in sampling mode. (Did you forget \ - [-sampling]?)" - | Custom { cyc; cyc_thresh; mtc; mtc_period; noretcomp; psb_period } -> - let make_config key = function - | None -> None - | Some value -> Some [%string "%{key}=%{value#Int}"] - in - [ make_config "cyc" (Option.map ~f:Bool.to_int cyc) - ; make_config "cyc_thresh" cyc_thresh - ; make_config "mtc" (Option.map ~f:Bool.to_int mtc) - ; make_config "mtc_period" mtc_period - ; make_config "noretcomp" (Option.map ~f:Bool.to_int noretcomp) - ; make_config "psb_period" psb_period - ] - |> List.filter_opt - |> String.concat ~sep:"," - |> Or_error.return + let ptw = + if Perf_capabilities.(do_intersect capabilities ptwrite) then "ptw" else "" + in + (* If ptwrite is not supported, we don't need to add it to the config string. *) + let config = + match timer_resolution with + | Low -> Or_error.return "" + | Normal -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0" + | High -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0,noretcomp=1" + | Sample _ -> + Or_error.error_string + "[-timer-resolution Sample] can only be used in sampling mode. (Did you forget \ + [-sampling]?)" + | Custom { cyc; cyc_thresh; mtc; mtc_period; noretcomp; psb_period } -> + let make_config key = function + | None -> None + | Some value -> Some [%string "%{key}=%{value#Int}"] + in + [ make_config "cyc" (Option.map ~f:Bool.to_int cyc) + ; make_config "cyc_thresh" cyc_thresh + ; make_config "mtc" (Option.map ~f:Bool.to_int mtc) + ; make_config "mtc_period" mtc_period + ; make_config "noretcomp" (Option.map ~f:Bool.to_int noretcomp) + ; make_config "psb_period" psb_period + ] + |> List.filter_opt + |> String.concat ~sep:"," + |> Or_error.return + in + match config with + | Ok config -> + if String.is_empty config + then Or_error.return [%string "%{ptw}"] + else Or_error.return [%string "%{config},%{ptw}"] + | Error _ as e -> e ;; let perf_cycles_config_of_timer_resolution (timer_resolution : Timer_resolution.t) = @@ -493,7 +505,7 @@ let decode_events Deferred.List.map files ~how:`Sequential ~f:(fun perf_data_file -> let itrace_opts = match collection_mode with - | Intel_processor_trace _ -> [ "--itrace=bep" ] + | Intel_processor_trace _ -> [ "--itrace=bepw" ] | Stacktrace_sampling _ -> [] in let fields_opts = diff --git a/src/trace.ml b/src/trace.ml index da41842ea..3cd7f008b 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -170,7 +170,10 @@ let write_trace_from_events | None -> Trace_writer.end_of_trace writer | Some to_time -> Trace_writer.end_of_trace ~to_time writer); last_index := index - | Ok { data = Event_sample _; _ } | Ok { data = Power _; _ } | Error _ -> ()); + | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } + | Ok { data = Power _; _ } + | Error _ -> ()); Trace_writer.write_event writer ?events_writer ev in let%bind () = diff --git a/src/trace_writer.ml b/src/trace_writer.ml index 6293daf4e..3c00030bf 100644 --- a/src/trace_writer.ml +++ b/src/trace_writer.ml @@ -1071,8 +1071,8 @@ and write_event' (T t) ?events_writer event = ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) ~default:[] ; Option.value_map - (Event.thread outer_event).pid - ~f:(fun pid -> [ "tid", Int (Pid.to_int pid) ]) + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) ~default:[] ]) in @@ -1083,6 +1083,29 @@ and write_event' (T t) ?events_writer event = ~name:track_name ~time ~time_end:time + | { Event.Ok.thread = _ (* Already used this to look up thread info. *) + ; time = _ + ; data = Ptwrite { location; data } + ; in_transaction = _ + } -> + let args = + Tracing.Trace.Arg.( + List.concat + [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] + ; [ "symbol", String (Symbol.display_name location.symbol) ] + ; [ "addr", Pointer location.instruction_pointer ] + ; [ "data", String data ] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) + ~default:[] + ; Option.value_map + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) + ~default:[] + ]) + in + write_duration_complete t ~thread ~args ~name:"PTWRITE" ~time ~time_end:time | { Event.Ok.thread = _ (* Already used this to look up thread info. *) ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) ; data = Power { freq } From 6db242aefa5e3a2e101528f215edc47071c1ef02 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 15 Jun 2026 15:01:04 -0400 Subject: [PATCH 2/5] stack switching --- src/new_trace_writer.ml | 76 ++++- src/perf_decode.ml | 16 +- src/perf_tool_backend.ml | 4 +- src/real_trace.ml | 10 + src/trace.ml | 6 + src/trace_segment.ml | 296 +++++++++++++----- src/trace_segment.mli | 7 +- src/trace_writer_intf.ml | 6 + test/perf_script.ml | 6 + test/sample-targets/ocaml-effects/dune | 12 + test/sample-targets/ocaml-effects/exn.ml | 14 + test/sample-targets/ocaml-effects/exn2.ml | 13 + test/sample-targets/ocaml-effects/migrate.ml | 76 +++++ .../ocaml-effects/sample-help-for-review.org | 11 + test/sample-targets/ocaml-effects/suspend.ml | 16 + test/sample-targets/ocaml-effects/suspend2.ml | 23 ++ .../ocaml-effects/suspend_exn.ml | 29 ++ .../ocaml-effects/suspend_exn2.ml | 22 ++ .../ocaml-effects/suspend_exn3.ml | 30 ++ .../ocaml-effects/suspend_exn4.ml | 29 ++ .../ocaml-effects/suspend_exn5.ml | 30 ++ 21 files changed, 641 insertions(+), 91 deletions(-) create mode 100644 test/sample-targets/ocaml-effects/dune create mode 100644 test/sample-targets/ocaml-effects/exn.ml create mode 100644 test/sample-targets/ocaml-effects/exn2.ml create mode 100644 test/sample-targets/ocaml-effects/migrate.ml create mode 100644 test/sample-targets/ocaml-effects/sample-help-for-review.org create mode 100644 test/sample-targets/ocaml-effects/suspend.ml create mode 100644 test/sample-targets/ocaml-effects/suspend2.ml create mode 100644 test/sample-targets/ocaml-effects/suspend_exn.ml create mode 100644 test/sample-targets/ocaml-effects/suspend_exn2.ml create mode 100644 test/sample-targets/ocaml-effects/suspend_exn3.ml create mode 100644 test/sample-targets/ocaml-effects/suspend_exn4.ml create mode 100644 test/sample-targets/ocaml-effects/suspend_exn5.ml diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index c50670464..eb0481659 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -59,16 +59,26 @@ module Thread_info = struct Trace_segment.add_event trace_segment event_data (Timestamp.create time) ;; + let set_fiber_id t fiber_id = + let #(trace_segment, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in + Trace_segment.set_fiber_id trace_segment fiber_id + ;; + module New_trace_segment_kind = struct type t = | Independent | Continuing_from_current end - let start_new_trace_segment t ~in_filtered_region ~(kind : New_trace_segment_kind.t) = + let start_new_trace_segment + t + ~in_filtered_region + ~(kind : New_trace_segment_kind.t) + ~fiber_stacks + = let new_trace_segment = match kind with - | Independent -> Trace_segment.create t.ocaml_exception_info + | Independent -> Trace_segment.create t.ocaml_exception_info fiber_stacks | Continuing_from_current -> let #(current, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in Trace_segment.create_continuing_from current @@ -89,6 +99,8 @@ type 'thread inner = ; annotate_inferred_start_times : bool ; mutable in_filtered_region : bool ; mutable transaction_events : Event.With_write_info.t Deque.t + ; pending_flows : ('thread -> Time_ns.Span.t -> unit) Hashtbl.M(Int).t + ; fiber_stacks : Trace_segment.Fiber.t Hashtbl.M(Int).t } type t = T : 'thread inner -> t @@ -230,6 +242,8 @@ let create_expert ; annotate_inferred_start_times ; in_filtered_region = true ; transaction_events = Deque.create () + ; pending_flows = Hashtbl.create (module Int) + ; fiber_stacks = Hashtbl.create (module Int) } in write_hits t hits; @@ -336,7 +350,7 @@ let create_thread t event = ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) ; trace_segments = Nonempty_vec.create - #( Trace_segment.create t.ocaml_exception_info + #( Trace_segment.create t.ocaml_exception_info t.fiber_stacks , ~in_filtered_region:t.in_filtered_region ) } ;; @@ -379,7 +393,8 @@ let maybe_start_filtered_region t ~should_write ~time:_ = Thread_info.start_new_trace_segment thread_info ~in_filtered_region:true - ~kind:Continuing_from_current); + ~kind:Continuing_from_current + ~fiber_stacks:t.fiber_stacks); t.in_filtered_region <- true) ;; @@ -392,7 +407,8 @@ let maybe_stop_filtered_region t ~should_write = Thread_info.start_new_trace_segment thread_info ~in_filtered_region:false - ~kind:Continuing_from_current)) + ~kind:Continuing_from_current + ~fiber_stacks:t.fiber_stacks)) ;; let write_event_and_callstack (events_writer : Tracing_tool_output.events_writer) event = @@ -501,6 +517,7 @@ and write_event' (T t) ?events_writer event = thread_info ~in_filtered_region:t.in_filtered_region ~kind:Independent + ~fiber_stacks:t.fiber_stacks | Ok event_value -> if should_write then @@ -532,8 +549,8 @@ and write_event' (T t) ?events_writer event = ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) ~default:[] ; Option.value_map - (Event.thread outer_event).pid - ~f:(fun pid -> [ "tid", Int (Pid.to_int pid) ]) + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) ~default:[] ]) in @@ -557,9 +574,50 @@ and write_event' (T t) ?events_writer event = ~args:Tracing.Trace.Arg.[ "freq (MHz)", Int freq ] | { Event.Ok.thread = _ (* Already used this to look up thread info. *) ; time = _ - ; data = Ptwrite _ + ; data = Ptwrite { location; data } ; in_transaction = _ - } -> () + } -> + let symbol_name = Symbol.display_name location.symbol in + let is_perform = String.equal symbol_name "caml_perform" in + let is_resume = String.equal symbol_name "caml_resume" in + if is_perform || is_resume + then ( + let fiber_id = Int64.to_int_trunc (Int64.of_string data) in + Thread_info.set_fiber_id thread_info fiber_id; + let name = if is_perform then "Perform Effect" else "Resume Continuation" in + let args = Tracing.Trace.Arg.[ "fiber", String (sprintf "0x%x" fiber_id) ] in + write_duration_complete t ~thread ~args ~name ~time ~time_end:time; + if is_perform + then ( + let module T = (val t.trace) in + let flow = T.create_flow () in + T.write_flow_step flow ~thread ~time:(time :> Time_ns.Span.t); + Hashtbl.set t.pending_flows ~key:fiber_id ~data:(fun thread time -> + T.write_flow_step flow ~thread ~time; + T.finish_flow flow)) + else ( + match Hashtbl.find_and_remove t.pending_flows fiber_id with + | Some finish -> finish thread (time :> Time_ns.Span.t) + | None -> ())) + else ( + let args = + Tracing.Trace.Arg.( + List.concat + [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] + ; [ "symbol", String symbol_name ] + ; [ "addr", Pointer location.instruction_pointer ] + ; [ "data", String data ] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) + ~default:[] + ; Option.value_map + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) + ~default:[] + ]) + in + write_duration_complete t ~thread ~args ~name:"PTWRITE" ~time ~time_end:time) | { Event.Ok.data = Stacktrace_sample _; _ } -> (* This should be unreachable, we currently delegate support for sampling to the old trace-writer. *) assert false) diff --git a/src/perf_decode.ml b/src/perf_decode.ml index 096986ef9..498ccc7e5 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -31,7 +31,7 @@ let perf_cbr_event_re = let perf_ptwrite_event_re = Re.Perl.re - {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +(0x[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} + {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +((?:0x)?[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} |> Re.compile ;; @@ -837,7 +837,19 @@ module%test _ = struct {| ((Ok ((thread ((pid (3285832)) (tid (3286108)))) (time 30d11h51m6.172476558s) - (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) |}] + (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) + |}] + ;; + + let%expect_test "perf ptwrite event zero payload" = + check + {|997136/997136 340026.788189283: 1 ptwrite: jcc IP: 0 payload: 0 0 64d20fb10432 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (997136)) (tid (997136)))) (time 3d22h27m6.788189283s) + (data (Ptwrite (location 0x64d20fb10432) (data 0)))))) + |}] ;; end diff --git a/src/perf_tool_backend.ml b/src/perf_tool_backend.ml index d2617afae..da78e151f 100644 --- a/src/perf_tool_backend.ml +++ b/src/perf_tool_backend.ml @@ -276,11 +276,11 @@ module Recording = struct |> Or_error.return in match config with - | Ok config -> + | Ok config when not (String.is_empty ptw) -> if String.is_empty config then Or_error.return [%string "%{ptw}"] else Or_error.return [%string "%{config},%{ptw}"] - | Error _ as e -> e + | Ok _ | Error _ -> config ;; let perf_cycles_config_of_timer_resolution (timer_resolution : Timer_resolution.t) = diff --git a/src/real_trace.ml b/src/real_trace.ml index 897b2d4c8..ec510bce3 100644 --- a/src/real_trace.ml +++ b/src/real_trace.ml @@ -19,6 +19,16 @@ let create (trace : Tracing.Trace.t) = let write_duration_complete = Tracing.Trace.write_duration_complete trace ~category:"" let write_duration_instant = Tracing.Trace.write_duration_instant trace ~category:"" let write_counter = Tracing.Trace.write_counter trace ~category:"" + + type flow = Tracing.Flow.t + + let create_flow () = Tracing.Trace.create_flow trace + + let write_flow_step flow ~thread ~time = + Tracing.Trace.write_flow_step trace flow ~thread ~time + ;; + + let finish_flow flow = Tracing.Trace.finish_flow trace flow end in (module T : S_trace with type thread = Tracing.Trace.Thread.t) diff --git a/src/trace.ml b/src/trace.ml index ed40db19c..0a7b65110 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -84,6 +84,12 @@ module Null_writer : Trace_writer_intf.S_trace = struct let write_duration_complete ~args:_ ~thread:_ ~name:_ ~time:_ ~time_end:_ : unit = () let write_duration_instant ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () let write_counter ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () + + type flow = unit + + let create_flow () = () + let write_flow_step () ~thread:_ ~time:_ = () + let finish_flow () = () end let write_trace_from_events diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 922dc13f9..99d49d3cd 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -14,7 +14,8 @@ module Frame : sig | Inlined (** An inlined function call, known to us solely via debug-info. *) end - (* The [location], [parent], and [kind] fields are actually **immutable** except for on [Sentinel.t] instances. *) + (* The [location], [parent], and [kind] fields are actually **immutable** except for on [Sentinel.t] instances. + [parent] is also mutated by [reparent] when splicing fiber stacks. *) type t = private { mutable location : Event.Location.t ; mutable parent : t or_null @@ -25,6 +26,7 @@ module Frame : sig val create : Location.t -> parent:t -> kind:Kind.t -> t val set_instruction_pointer : t -> int64 -> unit + val reparent : t -> t -> unit (** Find the first [Physical] frame whose [location.symbol] matches the provided argument. @@ -157,6 +159,8 @@ end = struct t.instruction_pointer <- instruction_pointer ;; + let[@inline always] reparent t parent = t.parent <- This parent + let rec find t target ~distance ~physical_distance ~leaf_of_inlined_stack = match t with | { parent = Null; _ } -> @@ -354,6 +358,14 @@ module Callstack = struct } end +module Fiber = struct + type t = + { mutable handler : Frame.t + ; mutable callstack : Callstack.t + ; exception_handlers : Frame.t Vec.t + } +end + type t = { mutable root : Frame.Sentinel.t ; mutable last_event_time : Timestamp.t @@ -373,6 +385,9 @@ type t = ; symbolizer : Symbolizer.t ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t + ; effect_handlers : (Frame.t * exn_depth:int) Vec.t + ; fiber_stacks : Fiber.t Hashtbl.M(Int).t + ; mutable last_known_fiber_id : int or_null (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -386,7 +401,18 @@ type t = ; mutable last_known_location : Location.t } -let create ocaml_exception_info = +let unknown_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; (* [Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range] does binary search + under-the-hood; initializing this to [Int64.max_value] intentionally makes the first + call terminate immediately. *) + instruction_pointer = Int64.max_value + ; dso = Null + } +;; + +let create ocaml_exception_info fiber_stacks = let root = Frame.Sentinel.create () in { root ; last_event_time = Timestamp.zero @@ -398,17 +424,12 @@ let create ocaml_exception_info = } : Callstack.t) ; symbolizer = Symbolizer.create () - ; exception_handlers = Vec.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info - ; last_known_location : Location.t = - { symbol = Unknown - ; symbol_offset = 0 - ; (* [Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range] does binary search - under-the-hood; initializing this to [Int64.max_value] intentionally makes the first - call terminate immediately. *) - instruction_pointer = Int64.max_value - ; dso = Null - } + ; exception_handlers = Vec.create () + ; effect_handlers = Vec.create () + ; fiber_stacks + ; last_known_fiber_id = Null + ; last_known_location = unknown_location } ;; @@ -419,6 +440,7 @@ let create_continuing_from existing = Nonempty_vec.create (#{ last_callstack with control_flow = Return { distance = 0 } } : Callstack.t) ; exception_handlers = Vec.copy existing.exception_handlers + ; effect_handlers = Vec.copy existing.effect_handlers } ;; @@ -701,7 +723,10 @@ let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) | #(Null, ~physical_distance:_, ..) -> log_unexpected_case - [%message "return [dst] does not match known trace state." (dst : Location.t)]; + [%message + "return [dst] does not match known trace state." + (dst : Location.t) + (dst.symbol : Symbol.t)]; (* Something is probably wrong if we ever make it to this case, where the state we're maintaining and the event we are processing seem to completely disagree. Treating it like a tail-call seems like the least bad option, and at the very @@ -761,35 +786,19 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = match t.ocaml_exception_info with | Null -> false | This ocaml_exception_info -> - Ocaml_exception_info.is_entertrap ocaml_exception_info ~addr:dst.instruction_pointer + (match Symbol.display_name dst.symbol, dst.symbol_offset with + | "caml_runstack", 0x13d -> true + | _ -> + Ocaml_exception_info.is_entertrap + ocaml_exception_info + ~addr:dst.instruction_pointer) ;; -let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = - match Vec.last t.exception_handlers with - | This dst_frame -> - Vec.pop_back_unit_exn t.exception_handlers; - assert (Symbol.equal dst_frame.location.symbol dst.symbol); - (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with - | #(~distance:(This distance), ~leaf_of_inlined_stack) -> - (* This is the happy case where our exception handler tracking is working as expected. *) - return_to_existing_frame - t - time - ~new_location:dst - ~frame:dst_frame - ~distance - ~leaf_of_inlined_stack - | #(~distance:Null, ..) -> - failwithf - "Invariant violated, exception handler '%s' was not found in the current \ - callstack" - (Symbol.display_name dst.symbol) - ()) - | Null -> - (match Frame.find_last_physical (current_frame t) with - | #(This frame, ~distance, ~leaf_of_inlined_stack) - when Symbol.equal frame.location.symbol dst.symbol -> - (* There are valid (but hopefully rare) ways to reach this case. +let return_to_unknown_handler (t : t) (time : Timestamp.t) ~(dst : Location.t) = + match Frame.find_last_physical (current_frame t) with + | #(This frame, ~distance, ~leaf_of_inlined_stack) + when Symbol.equal frame.location.symbol dst.symbol -> + (* There are valid (but hopefully rare) ways to reach this case. Take the following code for example: {v @@ -850,47 +859,173 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = deeper but unseen stack of non-tail recursive calls. OCaml being what it is, unfortunately I think code of both shapes actually exists. We go with the former interpretation because it should produce a readable trace in either scenario. - *) + *) + return_to_existing_frame + t + time + ~new_location:dst + ~frame + ~distance + ~leaf_of_inlined_stack + | #(maybe_frame, ~distance, ..) -> + (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) + let distance = + (* - Add 1 to the distance for the [_phantom_frame] we are injecting. + - Possibly add 1 more to the distance to return past the last physical frame (if it exists) + all the way to the sentinel. + *) + distance + 1 + (Or_null.is_this maybe_frame |> Bool.to_int) + in + let _phantom_frame = + let phantom_location : Location.t = + { instruction_pointer = 0L + ; symbol_offset = 0 + ; dso = Null + ; symbol = From_perf "[zero or more unknowable frames]" + } + in + emplace_root t phantom_location ~kind:Physical + in + let dst_frame = emplace_root t dst ~kind:Physical in + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + (* Unlike [handle_return] we do *not* make the inlined frames at [dst] (or [dst.instruction_pointer - 1]) + the parents of the existing frames. The rationale is that unlike [handle_return], we have no idea + where we might've been within the frame for [dst] that we just inferred. *) + append_inlined_frames + t + time + ~physical_frame:dst_frame + (* This is subtle; Yes the frame is new, but we *don't* want to reflect that in a + [Call], because discovered roots are handled separately. *) + ~and_insert_physical_frame_too:false +;; + +let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = + match Vec.last t.exception_handlers with + | This dst_frame -> + Vec.pop_back_unit_exn t.exception_handlers; + if not (Symbol.equal dst_frame.location.symbol dst.symbol) + then + log_unexpected_case + [%message + "Mismatched handler and dst" + (dst_frame.location.symbol : Symbol.t) + (dst.instruction_pointer : Int64.Hex.t) + (dst.symbol : Symbol.t)]; + (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with + | #(~distance:(This distance), ~leaf_of_inlined_stack) -> + (* This is the happy case where our exception handler tracking is working as expected. *) return_to_existing_frame t time ~new_location:dst - ~frame + ~frame:dst_frame ~distance ~leaf_of_inlined_stack - | #(maybe_frame, ~distance, ..) -> - (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) - let distance = - (* - Add 1 to the distance for the [_phantom_frame] we are injecting. - - Possibly add 1 more to the distance to return past the last physical frame (if it exists) - all the way to the sentinel. - *) - distance + 1 + (Or_null.is_this maybe_frame |> Bool.to_int) - in - let _phantom_frame = - let phantom_location : Location.t = - { instruction_pointer = 0L - ; symbol_offset = 0 - ; dso = Null - ; symbol = From_perf "[zero or more unknowable frames]" - } - in - emplace_root t phantom_location ~kind:Physical - in - let dst_frame = emplace_root t dst ~kind:Physical in - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = dst_frame; control_flow = Return { distance } }; - (* Unlike [handle_return] we do *not* make the inlined frames at [dst] (or [dst.instruction_pointer - 1]) - the parents of the existing frames. The rationale is that unlike [handle_return], we have no idea - where we might've been within the frame for [dst] that we just inferred. *) - append_inlined_frames + | #(~distance:Null, ..) -> + failwithf + "Invariant violated, exception handler '%s' was not found in the current \ + callstack" + (Symbol.display_name dst.symbol) + ()) + | Null -> return_to_unknown_handler t time ~dst +;; + +let set_fiber_id (t : t) fiber_id = t.last_known_fiber_id <- This fiber_id + +let current_fiber (t : t) ~time = + let fiber_id = Or_null.value ~default:0 t.last_known_fiber_id in + Hashtbl.find_or_add t.fiber_stacks fiber_id ~default:(fun () -> + { handler = current_frame t + ; callstack = + #{ time; leaf = current_frame t; control_flow = Return { distance = 0 } } + ; exception_handlers = Vec.create () + }) +;; + +(* Like [handle_ocaml_exception], but switches fibers *) +let handle_ocaml_perform (t : t) (time : Timestamp.t) ~(dst : Location.t) = + let fiber = current_fiber t ~time in + match Vec.last t.effect_handlers with + | This (dst_frame, ~exn_depth) -> + (* Stash this fiber's effect and exn handlers *) + fiber.handler <- dst_frame; + Vec.pop_back_unit_exn t.effect_handlers; + (* May not be empty if we're not getting ptwrite events *) + Vec.clear fiber.exception_handlers; + while Vec.length t.exception_handlers > exn_depth do + Vec.push_back fiber.exception_handlers (Vec.pop_back_exn t.exception_handlers) + done; + (* We expect the handler and dst to be different symbols. *) + (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with + | #(~distance:(This distance), ~leaf_of_inlined_stack) -> + (* Record the callstack between the handler and perform *) + fiber.callstack + <- #{ time; leaf = current_frame t; control_flow = Call { depth = distance } }; + return_to_existing_frame t time - ~physical_frame:dst_frame - (* This is subtle; Yes the frame is new, but we *don't* want to reflect that in a - [Call], because discovered roots are handled separately. *) - ~and_insert_physical_frame_too:false) + ~new_location:dst + ~frame:dst_frame + ~distance + ~leaf_of_inlined_stack + | #(~distance:Null, ..) -> + failwithf + "Invariant violated, effect handler '%s' was not found in the current callstack" + (Symbol.display_name dst.symbol) + ()) + | Null -> return_to_unknown_handler t time ~dst +;; + +let handle_ocaml_resume t time = + (* If we're not getting ptwrite events, the fiber info may have been overwritten by + another call to perform, but we attempt to use it anyway. *) + let fiber = current_fiber t ~time in + (* Restore the new fiber's effect and exn handlers *) + Vec.push_back + t.effect_handlers + (fiber.handler, ~exn_depth:(Vec.length t.exception_handlers)); + while Vec.length fiber.exception_handlers > 0 do + Vec.push_back t.exception_handlers (Vec.pop_back_exn fiber.exception_handlers) + done; + (* Return from caml_resume *) + Or_null.iter (current_frame t).parent ~f:(fun parent -> + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = parent; control_flow = Return { distance = 1 } }); + (* Splice in the new fiber's callstack between its handler and perform *) + let distance = + match Frame.find fiber.callstack.#leaf fiber.handler.location.symbol with + | #(This frame, ~distance, ~physical_distance:_, ~leaf_of_inlined_stack:_) -> + Frame.reparent frame (current_frame t); + distance + | _ -> 0 + in + fiber.callstack + <- #{ fiber.callstack with time; control_flow = Call { depth = distance + 1 } }; + Nonempty_vec.push_back t.callstacks fiber.callstack +;; + +let handle_ocaml_enter_runstack t ~current_physical_frame = + Vec.push_back + t.effect_handlers + (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); + (* Represents dynamic exnc callback *) + Vec.push_back t.exception_handlers current_physical_frame +;; + +let handle_ocaml_exit_runstack t = + match Vec.pop_back t.effect_handlers with + | This (_, ~exn_depth) -> + (* Drop exn handlers pushed in this fiber (including dynamic exnc callback) *) + while Vec.length t.exception_handlers > exn_depth do + Vec.pop_back_unit_exn t.exception_handlers + done + | Null -> + (* If we never saw the effect handler, we don't need to pop exn handlers *) + () ;; let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = @@ -954,7 +1089,7 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = ocaml_exception_info ~from:t.last_known_location.instruction_pointer ~to_:src.instruction_pointer - ~f:(stack_ fun (_address, kind) -> + ~f:(stack_ fun (_, kind) -> match kind with | Pushtrap -> Vec.push_back t.exception_handlers current_physical_frame | Poptrap -> @@ -974,7 +1109,14 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = ~current_exception_handler: (current_exception_handler.location : Location.t) ~current_physical_frame: - (current_physical_frame.location : Location.t)]))); + (current_physical_frame.location : Location.t)])); + (match Symbol.display_name src.symbol, src.symbol_offset with + (* CR-soon mslater: export these with the exception handler info *) + | "caml_runstack", 0xa9 -> handle_ocaml_enter_runstack t ~current_physical_frame + | "caml_runstack", 0x13b -> handle_ocaml_exit_runstack t + | "caml_perform", 0xb5 -> handle_ocaml_perform t time ~dst + | "caml_resume", 0xda -> handle_ocaml_resume t time + | _ -> ())); t.last_known_location <- dst | _ -> ()); (match event with @@ -1128,7 +1270,7 @@ end = struct let location = frame.location in assert (Timestamp.( >= ) time t.last_time); t.last_time <- time; - [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; + (* [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; *) if debug then eprintf "Exit %s\n" (Symbol.display_name location.symbol); t.write_duration_end ~args:[] @@ -1420,7 +1562,7 @@ module%test _ = struct end let setup_test () = - let t = create None in + let t = create None (Hashtbl.create (module Int)) in let ip = ref (-1) in let time = ref Time_ns.Span.zero in let incr_time () = time := Time_ns.Span.(!time + of_int_ns 1) in diff --git a/src/trace_segment.mli b/src/trace_segment.mli index 4b7d0d16d..89b5670e0 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -4,13 +4,18 @@ open! Core thread. *) type t -val create : Ocaml_exception_info.t option -> t +module Fiber : sig + type t +end + +val create : Ocaml_exception_info.t option -> Fiber.t Hashtbl.M(Int).t -> t (** Create a new trace segment that continues from the state of an existing segment, taking the existing segment's last callstack as the new segment's first callstack. *) val create_continuing_from : t -> t val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit +val set_fiber_id : t -> int -> unit val write_trace : t diff --git a/src/trace_writer_intf.ml b/src/trace_writer_intf.ml index 50c75c707..f94a05795 100644 --- a/src/trace_writer_intf.ml +++ b/src/trace_writer_intf.ml @@ -45,4 +45,10 @@ module type S_trace = sig -> name:string -> time:Time_ns.Span.t -> unit + + type flow + + val create_flow : unit -> flow + val write_flow_step : flow -> thread:thread -> time:Time_ns.Span.t -> unit + val finish_flow : flow -> unit end diff --git a/test/perf_script.ml b/test/perf_script.ml index 0be07a37a..39f9dab2c 100644 --- a/test/perf_script.ml +++ b/test/perf_script.ml @@ -45,6 +45,12 @@ let run ?(debug = false) ?events_writer ?ocaml_exception_info ~trace_scope file ;; let write_counter ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () + + type flow = unit + + let create_flow () = () + let write_flow_step () ~thread:_ ~time:_ = () + let finish_flow () = () end in Magic_trace_lib.Trace_writer.debug := debug; diff --git a/test/sample-targets/ocaml-effects/dune b/test/sample-targets/ocaml-effects/dune new file mode 100644 index 000000000..63db8afef --- /dev/null +++ b/test/sample-targets/ocaml-effects/dune @@ -0,0 +1,12 @@ +(executables + (names + exn + exn2 + migrate + suspend_exn + suspend_exn2 + suspend_exn3 + suspend_exn4 + suspend_exn5 + suspend + suspend2)) diff --git a/test/sample-targets/ocaml-effects/exn.ml b/test/sample-targets/ocaml-effects/exn.ml new file mode 100644 index 000000000..006895f50 --- /dev/null +++ b/test/sample-targets/ocaml-effects/exn.ml @@ -0,0 +1,14 @@ +let main () = + try + let effc (type a) (_ : a Effect.t) = None in + let[@inline never] exnc exn = + let _ = Sys.opaque_identity () in + raise exn + in + let handler = { Effect.Deep.retc = Fun.id; exnc; effc } in + Effect.Deep.match_with (fun () -> failwith "Failure") () handler + with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/exn2.ml b/test/sample-targets/ocaml-effects/exn2.ml new file mode 100644 index 000000000..f50d7fe96 --- /dev/null +++ b/test/sample-targets/ocaml-effects/exn2.ml @@ -0,0 +1,13 @@ +let[@inline never] fail () = failwith "Failure" + +let main () = + try + let effc (type a) (_ : a Effect.t) = None in + let handler = { Effect.Deep.retc = Fun.id; exnc = raise; effc } in + Effect.Deep.match_with (fun () -> ()) () handler; + fail () + with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/migrate.ml b/test/sample-targets/ocaml-effects/migrate.ml new file mode 100644 index 000000000..8089986f3 --- /dev/null +++ b/test/sample-targets/ocaml-effects/migrate.ml @@ -0,0 +1,76 @@ +[@@@alert "-do_not_spawn_domains"] +[@@@alert "-unsafe_multidomain"] + +type _ Effect.t += Migrate : unit Effect.t + +let rec push stack item = + let before = Atomic.get stack in + let after = item :: before in + if not (Atomic.compare_and_set stack before after) then push stack item +;; + +let x = ref 0 + +let[@inline never] perform0 () = + x := !x + 1; + Effect.perform Migrate +;; + +let[@inline never] perform1 () = + x := !x + 1; + perform0 () [@nontail] +;; + +let[@inline never] perform2 () = + x := !x + 1; + perform1 () [@nontail] +;; + +let[@inline never] perform3 () = + x := !x + 1; + perform2 () [@nontail] +;; + +let main () = + let fibers_in = Atomic.make [] in + let receiving_domain = + Domain.spawn (fun () -> + try + let rec loop = function + | fiber :: fibers -> + fiber (); + loop fibers + | [] -> + while Atomic.get fibers_in == [] do + Domain.cpu_relax () + done; + loop (List.rev (Atomic.exchange fibers_in [])) + in + loop [] + with + | Exit -> ()) + in + let finally () = + push fibers_in (fun () -> raise Exit); + Domain.join receiving_domain + in + Fun.protect ~finally (fun () -> + let effc (type a) (e : a Effect.t) = + match e with + | Migrate -> + Some + (fun (k : (a, unit) Effect.Deep.continuation) -> + push fibers_in (Effect.Deep.continue k)) + | _ -> None + in + let handler = { Effect.Deep.retc = Fun.id; exnc = raise; effc } in + for _ = 1 to 200 do + Effect.Deep.match_with + (fun () -> if Random.bool () then perform3 () else perform1 () [@nontail]) + () + handler + done; + Printf.printf "OK\n%!") +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/sample-help-for-review.org b/test/sample-targets/ocaml-effects/sample-help-for-review.org new file mode 100644 index 000000000..6e9777b22 --- /dev/null +++ b/test/sample-targets/ocaml-effects/sample-help-for-review.org @@ -0,0 +1,11 @@ +* sample.exe + +: sample executable for tracing that unwinds 20 stack frames in an ocaml exception +: +: sample.exe +: +: === flags === +: +: [-build-info] . print info about this build and exit +: [-version] . print the version of this build and exit +: [-help], -? . print this help text and exit diff --git a/test/sample-targets/ocaml-effects/suspend.ml b/test/sample-targets/ocaml-effects/suspend.ml new file mode 100644 index 000000000..43e950eb1 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend.ml @@ -0,0 +1,16 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> Some (fun (_ : (a, unit) Effect.Deep.continuation) -> ()) + | _ -> None + in + let handler = { Effect.Deep.retc = Fun.id; exnc = raise; effc } in + for _ = 1 to 10 do + Effect.Deep.match_with (fun () -> Effect.perform Suspend) () handler + done; + Printf.printf "OK\n%!" +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend2.ml b/test/sample-targets/ocaml-effects/suspend2.ml new file mode 100644 index 000000000..275808bc7 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend2.ml @@ -0,0 +1,23 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> + Some (fun (k : (a, unit) Effect.Deep.continuation) -> Effect.Deep.continue k ()) + | _ -> None + in + let handler = { Effect.Deep.retc = Fun.id; exnc = raise; effc } in + for _ = 1 to 10 do + Effect.Deep.match_with + (fun () -> + Effect.perform Suspend; + Effect.perform Suspend; + Effect.perform Suspend) + () + handler + done; + Printf.printf "OK\n%!" +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend_exn.ml b/test/sample-targets/ocaml-effects/suspend_exn.ml new file mode 100644 index 000000000..accb08d43 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend_exn.ml @@ -0,0 +1,29 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> Some (fun (_ : (a, unit) Effect.Deep.continuation) -> failwith "Failure") + | _ -> None + in + let handler = + { Effect.Deep.retc = Fun.id + ; exnc = + (fun exn -> + print_string "exnc"; + raise exn) + ; effc + } + in + try + Effect.Deep.match_with + (fun () -> + try Effect.perform Suspend with + | _ -> ()) + () + handler + with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend_exn2.ml b/test/sample-targets/ocaml-effects/suspend_exn2.ml new file mode 100644 index 000000000..4363a2923 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend_exn2.ml @@ -0,0 +1,22 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> failwith "Failure" + | _ -> None + in + let handler = + { Effect.Deep.retc = Fun.id + ; exnc = + (fun exn -> + print_string "exnc"; + raise exn) + ; effc + } + in + try Effect.Deep.match_with (fun () -> Effect.perform Suspend) () handler with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend_exn3.ml b/test/sample-targets/ocaml-effects/suspend_exn3.ml new file mode 100644 index 000000000..bb1ad2fa3 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend_exn3.ml @@ -0,0 +1,30 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> + Some (fun (k : (a, unit) Effect.Deep.continuation) -> Effect.Deep.continue k ()) + | _ -> None + in + let handler = + { Effect.Deep.retc = Fun.id + ; exnc = + (fun exn -> + print_endline "exnc"; + raise exn) + ; effc + } + in + try + Effect.Deep.match_with + (fun () -> + Effect.perform Suspend; + failwith "Failure") + () + handler + with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend_exn4.ml b/test/sample-targets/ocaml-effects/suspend_exn4.ml new file mode 100644 index 000000000..35dae6f73 --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend_exn4.ml @@ -0,0 +1,29 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let cont : (unit, unit) Effect.Deep.continuation option ref = ref None in + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> Some (fun (k : (a, unit) Effect.Deep.continuation) -> cont := Some k) + | _ -> None + in + let handler = + { Effect.Deep.retc = Fun.id + ; exnc = + (fun exn -> + print_endline "exnc"; + raise exn) + ; effc + } + in + Effect.Deep.match_with + (fun () -> + Effect.perform Suspend; + failwith "Failure") + () + handler; + try Effect.Deep.continue (Option.get !cont) () with + | Failure fail -> print_endline fail +;; + +let () = main () diff --git a/test/sample-targets/ocaml-effects/suspend_exn5.ml b/test/sample-targets/ocaml-effects/suspend_exn5.ml new file mode 100644 index 000000000..41448162d --- /dev/null +++ b/test/sample-targets/ocaml-effects/suspend_exn5.ml @@ -0,0 +1,30 @@ +type _ Effect.t += Suspend : unit Effect.t + +let main () = + let cont : (unit, unit) Effect.Deep.continuation option ref = ref None in + let effc (type a) (e : a Effect.t) = + match e with + | Suspend -> Some (fun (k : (a, unit) Effect.Deep.continuation) -> cont := Some k) + | _ -> None + in + let handler = + { Effect.Deep.retc = Fun.id + ; exnc = + (fun exn -> + print_endline "exnc"; + raise exn) + ; effc + } + in + Effect.Deep.match_with + (fun () -> + Effect.Deep.match_with (fun () -> Effect.perform Suspend) () handler; + Effect.perform Suspend; + failwith "Failure") + () + handler; + try Effect.Deep.continue (Option.get !cont) () with + | Failure fail -> print_endline fail +;; + +let () = main () From a84e3c94d99519a9da045d9bc410a562bf23b943 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 15 Jun 2026 15:03:34 -0400 Subject: [PATCH 3/5] move comment --- src/perf_tool_backend.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/perf_tool_backend.ml b/src/perf_tool_backend.ml index da78e151f..001320fa2 100644 --- a/src/perf_tool_backend.ml +++ b/src/perf_tool_backend.ml @@ -249,7 +249,6 @@ module Recording = struct let ptw = if Perf_capabilities.(do_intersect capabilities ptwrite) then "ptw" else "" in - (* If ptwrite is not supported, we don't need to add it to the config string. *) let config = match timer_resolution with | Low -> Or_error.return "" @@ -275,6 +274,7 @@ module Recording = struct |> String.concat ~sep:"," |> Or_error.return in + (* If ptwrite is not supported, we don't need to add it to the config string. *) match config with | Ok config when not (String.is_empty ptw) -> if String.is_empty config From 9eb7941a543efb6f0c93937eebafe348d060d319 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 15 Jun 2026 15:04:42 -0400 Subject: [PATCH 4/5] revert unknown_location --- src/trace_segment.ml | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 99d49d3cd..9ebf8c142 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -401,17 +401,6 @@ type t = ; mutable last_known_location : Location.t } -let unknown_location : Location.t = - { symbol = Unknown - ; symbol_offset = 0 - ; (* [Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range] does binary search - under-the-hood; initializing this to [Int64.max_value] intentionally makes the first - call terminate immediately. *) - instruction_pointer = Int64.max_value - ; dso = Null - } -;; - let create ocaml_exception_info fiber_stacks = let root = Frame.Sentinel.create () in { root @@ -429,7 +418,15 @@ let create ocaml_exception_info fiber_stacks = ; effect_handlers = Vec.create () ; fiber_stacks ; last_known_fiber_id = Null - ; last_known_location = unknown_location + ; last_known_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; (* [Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range] does binary search + under-the-hood; initializing this to [Int64.max_value] intentionally makes the first + call terminate immediately. *) + instruction_pointer = Int64.max_value + ; dso = Null + } } ;; From de8f7da6b805b8f1f58feca93ec52e3c4a252efc Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 15 Jun 2026 15:08:15 -0400 Subject: [PATCH 5/5] minor fix --- src/trace_segment.ml | 10 ++++------ .../ocaml-effects/sample-help-for-review.org | 11 ----------- 2 files changed, 4 insertions(+), 17 deletions(-) delete mode 100644 test/sample-targets/ocaml-effects/sample-help-for-review.org diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 9ebf8c142..7cc6a155f 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -720,10 +720,7 @@ let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) | #(Null, ~physical_distance:_, ..) -> log_unexpected_case - [%message - "return [dst] does not match known trace state." - (dst : Location.t) - (dst.symbol : Symbol.t)]; + [%message "return [dst] does not match known trace state." (dst : Location.t)]; (* Something is probably wrong if we ever make it to this case, where the state we're maintaining and the event we are processing seem to completely disagree. Treating it like a tail-call seems like the least bad option, and at the very @@ -784,6 +781,7 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = | Null -> false | This ocaml_exception_info -> (match Symbol.display_name dst.symbol, dst.symbol_offset with + (* CR-soon mslater: export this with the exception handler info *) | "caml_runstack", 0x13d -> true | _ -> Ocaml_exception_info.is_entertrap @@ -1086,7 +1084,7 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = ocaml_exception_info ~from:t.last_known_location.instruction_pointer ~to_:src.instruction_pointer - ~f:(stack_ fun (_, kind) -> + ~f:(stack_ fun (_address, kind) -> match kind with | Pushtrap -> Vec.push_back t.exception_handlers current_physical_frame | Poptrap -> @@ -1267,7 +1265,7 @@ end = struct let location = frame.location in assert (Timestamp.( >= ) time t.last_time); t.last_time <- time; - (* [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; *) + [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; if debug then eprintf "Exit %s\n" (Symbol.display_name location.symbol); t.write_duration_end ~args:[] diff --git a/test/sample-targets/ocaml-effects/sample-help-for-review.org b/test/sample-targets/ocaml-effects/sample-help-for-review.org deleted file mode 100644 index 6e9777b22..000000000 --- a/test/sample-targets/ocaml-effects/sample-help-for-review.org +++ /dev/null @@ -1,11 +0,0 @@ -* sample.exe - -: sample executable for tracing that unwinds 20 stack frames in an ocaml exception -: -: sample.exe -: -: === flags === -: -: [-build-info] . print info about this build and exit -: [-version] . print the version of this build and exit -: [-help], -? . print this help text and exit