CA-421084: xstringext: Improve performance of escaped

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

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)
+)

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)
 )

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)

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
+    ]

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"