diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml new file mode 100644 index 00000000000..52897ee2a0c --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml @@ -0,0 +1,130 @@ +open Bechamel +open Toolkit +module XString = Xapi_stdext_std.Xstringext.String + +(* Test data generators *) +let make_string len = String.init len (fun i -> Char.chr (33 + (i mod 94))) + +let escape_rules = + [('a', "[A]"); ('e', "[E]"); ('i', "[I]"); ('o', "[O]"); ('u', "[U]")] + +(* Reference implementation from xstringext_test.ml *) +let escaped_spec ?rules string = + match rules with + | None -> + String.escaped string + | Some rules -> + let apply_rules char = + match List.assoc_opt char rules with + | None -> + Seq.return char + | Some replacement -> + String.to_seq replacement + in + string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq + +let escaped_benchmark n = + let s = make_string n in + Staged.stage @@ fun () -> ignore (XString.escaped ~rules:escape_rules s) + +let escaped_spec_benchmark n = + let s = make_string n in + Staged.stage @@ fun () -> ignore (escaped_spec ~rules:escape_rules s) + +let test_escaped = + Test.make_indexed ~name:"escaped" ~fmt:"%s %d" ~args:[100; 500; 1000] + escaped_benchmark + +let test_escaped_spec = + Test.make_indexed ~name:"escaped-spec" ~fmt:"%s %d" ~args:[100; 500; 1000] + escaped_spec_benchmark + +let benchmark () = + let ols = + Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[|run|] + in + let instances = + Instance.[minor_allocated; major_allocated; monotonic_clock] + in + let cfg = + Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) () + in + let test = + Test.make_grouped ~name:"escaped-comparison" + [test_escaped; test_escaped_spec] + in + let raw_results = Benchmark.all cfg instances test in + let results = + List.map (fun instance -> Analyze.all ols instance raw_results) instances + in + let results = Analyze.merge ols instances results in + (results, raw_results) + +let () = + let all_results = benchmark () in + let results, _ = all_results in + + (* Extract timing data from the actual benchmark results *) + let result_groups = + Hashtbl.fold + (fun _ v a -> Hashtbl.fold (fun k v a -> (k, v) :: a) v [] :: a) + results [] + in + + (* Find the monotonic-clock result group (timing data) *) + let timing_group = + match result_groups with _ :: _ :: timing :: _ -> Some timing | _ -> None + in + + let get_timing test_name = + match timing_group with + | None -> + None + | Some group -> ( + match List.assoc_opt test_name group with + | Some estimator -> ( + let estimates = Analyze.OLS.estimates estimator in + match estimates with Some (x :: _) -> Some x | _ -> None + ) + | None -> + None + ) + in + + Printf.printf "\n=== Performance Comparison: Optimized vs Reference ===\n\n" ; + + let sizes = ["100"; "500"; "1000"] in + List.iter + (fun size -> + Printf.printf "String size %s:\n" size ; + let opt_test = Printf.sprintf "escaped-comparison/escaped %s" size in + let ref_test = Printf.sprintf "escaped-comparison/escaped-spec %s" size in + match (get_timing opt_test, get_timing ref_test) with + | Some opt_time, Some ref_time -> + let improvement = (ref_time -. opt_time) /. ref_time *. 100.0 in + Printf.printf " Optimized: %.3f μs\n" opt_time ; + Printf.printf " Reference: %.3f μs\n" ref_time ; + Printf.printf " Improvement: %.1f%% %s\n\n" improvement + (if improvement > 0.0 then "faster" else "slower") + | None, _ -> + Printf.printf " Optimized implementation data missing\n\n" + | _, None -> + Printf.printf " Reference implementation data missing\n\n" + ) + sizes ; + + Printf.printf "\n=== Detailed Results ===\n" ; + match result_groups with + | [results] -> + let print (k, ols) = Fmt.pr "%s: %a\n%!" k Analyze.OLS.pp ols in + List.iter print results + | results_list -> + Printf.printf "Results structure: %d result groups\n" + (List.length results_list) ; + List.iteri + (fun i results -> + Printf.printf "Result group %d:\n" i ; + let print (k, ols) = Fmt.pr " %s: %a\n%!" k Analyze.OLS.pp ols in + List.iter print results + ) + results_list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune new file mode 100644 index 00000000000..27467a09029 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune @@ -0,0 +1,6 @@ +(executable + (name bench_xstringext) + (modes exe) + (optional) + (libraries bechamel xapi-stdext-std bechamel-notty notty.unix fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune index 67d48233bc4..d869973d411 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune @@ -7,5 +7,5 @@ (names xstringext_test listext_test) (package xapi-stdext-std) (modules xstringext_test listext_test) - (libraries xapi_stdext_std fmt alcotest) + (libraries xapi_stdext_std fmt alcotest qcheck-core qcheck-alcotest) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml index 16f60dedbae..4e5379d7b36 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -42,21 +42,6 @@ module String = struct (** Returns true for whitespace characters, false otherwise *) let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false - let escaped ?rules string = - match rules with - | None -> - String.escaped string - | Some rules -> - let aux h t = - ( if List.mem_assoc h rules then - List.assoc h rules - else - of_char h - ) - :: t - in - concat "" (fold_right aux string []) - let split_f p str = let split_one seq = let not_p c = not (p c) in @@ -193,6 +178,13 @@ module String = struct ) else s + let escaped ?rules s = + match rules with + | None -> + String.escaped s + | Some rules -> + map_unlikely s (fun c -> List.assoc_opt c rules) + let sub_to_end s start = let length = String.length s in String.sub s start (length - start) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml index 145ce632bbc..9b7eb2674a1 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml @@ -147,6 +147,49 @@ let test_rtrim = in ("rtrim", List.map test spec) +(** Simple implementation of escaped for testing against *) +let escaped_spec ?rules string = + match rules with + | None -> + String.escaped string + | Some rules -> + let apply_rules char = + match List.assoc_opt char rules with + | None -> + Seq.return char + | Some replacement -> + String.to_seq replacement + in + string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq + +let test_escaped = + let open QCheck2 in + (* Generator for escape rules: list of (char, string) mappings *) + let gen_rules = + let open Gen in + let gen_rule = pair char (string_size (int_range 0 5) ~gen:char) in + list gen_rule + in + (* Generator for test input: string and optional rules *) + let gen_input = Gen.pair Gen.string (Gen.opt gen_rules) in + let property (s, rules) = + let expected = escaped_spec ?rules s in + let actual = XString.escaped ?rules s in + String.equal expected actual + in + let test = + Test.make ~name:"escaped matches reference implementation" ~count:1000 + gen_input property + in + ("escaped", [QCheck_alcotest.to_alcotest test]) + let () = Alcotest.run "Xstringext" - [test_rev_map; test_split; test_split_f; test_has_substr; test_rtrim] + [ + test_rev_map + ; test_split + ; test_split_f + ; test_has_substr + ; test_rtrim + ; test_escaped + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/quality-gate.sh b/quality-gate.sh index b2345f75ef7..6785610ff30 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=461 + N=460 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test"