From 6e38345c54bd0fcb48de5c2e6d315260a0182d03 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 28 Aug 2026 09:40:39 +0100 Subject: [PATCH] perf(stdune): avoid allocations in string and path helpers Expose unchecked string search operations for callers that use an integer sentinel, avoid intermediate search options in path operations, and allocate Filename.concat results in one pass. Signed-off-by: Rudi Grinberg --- otherlibs/dune-action-plugin/src/path.ml | 2 +- otherlibs/stdune/src/filename.ml | 16 +++++++ otherlibs/stdune/src/path0.ml | 22 +++++---- otherlibs/stdune/src/string.ml | 15 ++++++ otherlibs/stdune/src/string.mli | 11 +++++ otherlibs/stdune/test/filename_tests.ml | 13 ++++++ otherlibs/stdune/test/path_tests.ml | 23 +++++++++ otherlibs/stdune/test/string_tests.ml | 59 ++++++++++++++++++++++++ 8 files changed, 151 insertions(+), 10 deletions(-) diff --git a/otherlibs/dune-action-plugin/src/path.ml b/otherlibs/dune-action-plugin/src/path.ml index ba2f2881811..59743b14ea0 100644 --- a/otherlibs/dune-action-plugin/src/path.ml +++ b/otherlibs/dune-action-plugin/src/path.ml @@ -1,6 +1,6 @@ type t = string -let concat = Filename.concat +let concat = Stdune.Filename.concat let to_string t = t let of_string path = diff --git a/otherlibs/stdune/src/filename.ml b/otherlibs/stdune/src/filename.ml index db73eb32482..6e9a62f7bbf 100644 --- a/otherlibs/stdune/src/filename.ml +++ b/otherlibs/stdune/src/filename.ml @@ -2,6 +2,22 @@ include Stdlib.Filename type t = string +let is_dir_sep = + if Sys.win32 || Sys.cygwin + then + function + | '/' | '\\' | ':' -> true + | _ -> false + else Char.equal '/' +;; + +let concat dirname filename = + let length = String.length dirname in + if length = 0 || is_dir_sep (String.unsafe_get dirname (length - 1)) + then dirname ^ filename + else String.append_with_char dirname ~sep:(String.unsafe_get dir_sep 0) filename +;; + let rec contains_slash s i = i >= 0 && (Char.equal (String.unsafe_get s i) '/' || contains_slash s (i - 1)) ;; diff --git a/otherlibs/stdune/src/path0.ml b/otherlibs/stdune/src/path0.ml index 8b01f2cd159..249ccfe012b 100644 --- a/otherlibs/stdune/src/path0.ml +++ b/otherlibs/stdune/src/path0.ml @@ -52,9 +52,9 @@ module Local_gen = struct if is_root t then None else ( - match String.rindex_from t (String.length t - 1) '/' with - | None -> Some root - | Some i -> Some (String.take t i)) + match String.rindex_from_unchecked t (String.length t - 1) '/' with + | -1 -> Some root + | i -> Some (String.take t i)) ;; let basename t = @@ -63,9 +63,9 @@ module Local_gen = struct then Code_error.raise "Path.Local.basename called on the root" [] else ( let len = String.length t in - match String.rindex_from t (len - 1) '/' with - | None -> t - | Some i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1)) + match String.rindex_from_unchecked t (len - 1) '/' with + | -1 -> t + | i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1)) in Filename.of_string_unchecked basename ;; @@ -390,9 +390,13 @@ module Local_gen = struct if is_root t then None else ( - match String.lsplit2 t ~on:'/' with - | None -> Some (Filename.of_string_unchecked t, root) - | Some (before, after) -> Some (Filename.of_string_unchecked before, after)) + match String.index_from_unchecked t 0 '/' with + | -1 -> Some (Filename.of_string_unchecked t, root) + | separator -> + let length = String.length t in + let before = String.sub t ~pos:0 ~len:separator |> Filename.of_string_unchecked in + let after = String.sub t ~pos:(separator + 1) ~len:(length - separator - 1) in + Some (before, after)) ;; let explode p = diff --git a/otherlibs/stdune/src/string.ml b/otherlibs/stdune/src/string.ml index ae7b0f5e8f8..33cf78f4c57 100644 --- a/otherlibs/stdune/src/string.ml +++ b/otherlibs/stdune/src/string.ml @@ -76,6 +76,21 @@ module Caseless = Cased_functions (struct include Stdlib.StringLabels +let index_from_unchecked s i c = + let length = length s in + let rec loop i = + if i = length then -1 else if Char.equal (unsafe_get s i) c then i else loop (i + 1) + in + loop i +;; + +let rindex_from_unchecked s i c = + let rec loop i = + if i = -1 then -1 else if Char.equal (unsafe_get s i) c then i else loop (i - 1) + in + loop i +;; + (* [StringLabels] shadows these implementations with versions that allocate a local recursive closure on each call. *) let starts_with = Case_sensitive.starts_with diff --git a/otherlibs/stdune/src/string.mli b/otherlibs/stdune/src/string.mli index 9cde37ef681..8324a35b462 100644 --- a/otherlibs/stdune/src/string.mli +++ b/otherlibs/stdune/src/string.mli @@ -52,6 +52,17 @@ val index : t -> char -> int option val index_from : t -> int -> char -> int option val rindex : t -> char -> int option val rindex_from : t -> int -> char -> int option + +(** [index_from_unchecked s pos char] returns the first index of [char] at or + after [pos], or [-1] if it is absent. [pos] must be between [0] and + [length s]. *) +val index_from_unchecked : t -> int -> char -> int + +(** [rindex_from_unchecked s pos char] returns the last index of [char] at or + before [pos], or [-1] if it is absent. [pos] must be between [-1] and + [length s - 1]. *) +val rindex_from_unchecked : t -> int -> char -> int + val extract_words : t -> is_word_char:(char -> bool) -> t list val extract_comma_space_separated_words : t -> t list val extract_blank_separated_words : t -> t list diff --git a/otherlibs/stdune/test/filename_tests.ml b/otherlibs/stdune/test/filename_tests.ml index 545a3cc0ac5..466d36e4c44 100644 --- a/otherlibs/stdune/test/filename_tests.ml +++ b/otherlibs/stdune/test/filename_tests.ml @@ -30,6 +30,19 @@ let%expect_test "filenames reject platform directory separators" = |}] ;; +let%expect_test "concat agrees with the standard library" = + let directories = [ ""; "."; "dir"; "dir/"; "dir\\"; "C:" ] in + let filenames = [ ""; "file"; "sub/file" ] in + List.iter directories ~f:(fun directory -> + List.iter filenames ~f:(fun filename -> + assert ( + String.equal + (Filename.concat directory filename) + (Stdlib.Filename.concat directory filename)))); + print_endline "all concatenations agree"; + [%expect {| all concatenations agree |}] +;; + let extension s = let ext = Filename.of_string s diff --git a/otherlibs/stdune/test/path_tests.ml b/otherlibs/stdune/test/path_tests.ml index 2030df4ed54..99076674dcc 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -99,6 +99,29 @@ let%expect_test "local path parsing produces canonical representations" = |}] ;; +let%expect_test "canonical local component boundaries" = + let option f = function + | None -> "none" + | Some value -> f value + in + List.iter [ "."; "one"; "one/two" ] ~f:(fun input -> + let path = Path.Local.of_string input in + let parent = Path.Local.parent path |> option Path.Local.to_string in + let basename = Path.Local.basename_opt path |> option Filename.to_string in + let first = + Path.Local.split_first_component path + |> option (fun (first, rest) -> + sprintf "%s,%s" (Filename.to_string first) (Path.Local.to_string rest)) + in + printfn "%s: parent=%s basename=%s first=%s" input parent basename first); + [%expect + {| + .: parent=none basename=none first=none + one: parent=. basename=one first=one,. + one/two: parent=one basename=two first=one,two + |}] +;; + let%expect_test _ = let p = Path.(relative root) "foo" in descendant p ~of_:p; diff --git a/otherlibs/stdune/test/string_tests.ml b/otherlibs/stdune/test/string_tests.ml index 6f3704026b2..dc4c0815194 100644 --- a/otherlibs/stdune/test/string_tests.ml +++ b/otherlibs/stdune/test/string_tests.ml @@ -220,6 +220,65 @@ let%expect_test "extract blank separated words" = |}] ;; +let search_test_strings = + [ "" + ; "a" + ; "abcdefgh" + ; "abcdefghi" + ; String.init 257 ~f:(fun i -> Char.chr (i land 0xff)) + ] +;; + +let%expect_test "contains agrees with the standard library" = + List.iter search_test_strings ~f:(fun s -> + for code = 0 to 255 do + let char = Char.chr code in + assert (Bool.equal (String.contains s char) (Stdlib.String.contains s char)) + done); + let unchanged = "unchanged" in + assert (String.escape_only 'x' unchanged == unchanged); + print_endline "all searches agree"; + [%expect {| all searches agree |}] +;; + +let%expect_test "forward searches agree with the standard library" = + List.iter search_test_strings ~f:(fun s -> + for pos = 0 to String.length s do + for code = 0 to 255 do + let char = Char.chr code in + let expected = Stdlib.String.index_from_opt s pos char in + assert (Option.equal Int.equal (String.index_from s pos char) expected); + assert ( + Int.equal + (String.index_from_unchecked s pos char) + (Option.value expected ~default:(-1))); + assert ( + Bool.equal + (String.contains_from s pos char) + (Stdlib.String.contains_from s pos char)) + done + done); + print_endline "all searches agree"; + [%expect {| all searches agree |}] +;; + +let%expect_test "reverse searches agree with the standard library" = + List.iter search_test_strings ~f:(fun s -> + for pos = -1 to String.length s - 1 do + for code = 0 to 255 do + let char = Char.chr code in + let expected = Stdlib.String.rindex_from_opt s pos char in + assert (Option.equal Int.equal (String.rindex_from s pos char) expected); + assert ( + Int.equal + (String.rindex_from_unchecked s pos char) + (Option.value expected ~default:(-1))) + done + done); + print_endline "all searches agree"; + [%expect {| all searches agree |}] +;; + let%expect_test "split_lines preserves carriage returns outside CRLF" = List.iter [ "\r"; "first\n\r"; "first\rsecond"; "first\r\nsecond" ] ~f:(fun s -> String.split_lines s |> list string |> print_dyn);