From f6bb92fdb6f7a5a59cc770b10b841bd6b6dc8695 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Jun 2026 15:41:31 -0400 Subject: [PATCH 1/5] check for empty needle in CCString.Find --- src/core/CCString.ml | 2 ++ src/core/CCString.mli | 13 ++++++++++++- tests/core/t_string.ml | 4 ++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/src/core/CCString.ml b/src/core/CCString.ml index 048e06f1c..76b22e3b1 100644 --- a/src/core/CCString.ml +++ b/src/core/CCString.ml @@ -181,12 +181,14 @@ module Find = struct | P_KMP p -> kmp_pattern_length p let compile sub : [ `Direct ] pattern = + if length sub = 0 then invalid_arg "CCString.Find.compile: empty pattern"; if length sub = 1 then P_char sub.[0] else P_KMP (kmp_compile sub) let rcompile sub : [ `Reverse ] pattern = + if length sub = 0 then invalid_arg "CCString.Find.rcompile: empty pattern"; if length sub = 1 then P_char sub.[0] else diff --git a/src/core/CCString.mli b/src/core/CCString.mli index daffcbdf5..a1e7fd1d2 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -104,27 +104,32 @@ val to_array : string -> char array val find : ?start:int -> sub:string -> string -> int (** [find ~start ~sub s] returns the starting index of the first occurrence of [sub] within [s] or [-1]. - @param start starting position in [s]. *) + @param start starting position in [s]. + @raise Invalid_argument if [sub = ""]. *) val find_all : ?start:int -> sub:string -> string -> int gen (** [find_all ~start ~sub s] finds all occurrences of [sub] in [s], even overlapping instances and returns them in a generator [gen]. @param start starting position in [s]. + @raise Invalid_argument if [sub = ""]. @since 0.17 *) val find_all_l : ?start:int -> sub:string -> string -> int list (** [find_all_l ~sub s] finds all occurrences of [sub] in [s] and returns them in a list. @param start starting position in [s]. + @raise Invalid_argument if [sub = ""]. @since 0.17 *) val mem : ?start:int -> sub:string -> string -> bool (** [mem ~start ~sub s] is [true] iff [sub] is a substring of [s]. + @raise Invalid_argument if [sub = ""]. @since 0.12 *) val rfind : sub:string -> string -> int (** [rfind ~sub s] finds [sub] in string [s] from the right, returns its first index or [-1]. Should only be used with very small [sub]. + @raise Invalid_argument if [sub = ""]. @since 0.12 *) val replace : @@ -353,7 +358,12 @@ module Find : sig type _ pattern val compile : string -> [ `Direct ] pattern + (** [compile sub] compiles [sub] into a pattern usable with {!find}. + @raise Invalid_argument if [sub = ""]. *) + val rcompile : string -> [ `Reverse ] pattern + (** [rcompile sub] compiles [sub] into a pattern usable with {!rfind}. + @raise Invalid_argument if [sub = ""]. *) val find : ?start:int -> pattern:[ `Direct ] pattern -> string -> int (** [find ~start ~pattern s] searches for [pattern] in the string [s], left-to-right. @@ -465,6 +475,7 @@ end val split : by:string -> string -> string list (** [split ~by s] splits the string [s] along the given string [by]. Alias to {!Split.list_cpy}. + @raise Invalid_argument if [by = ""]. @since 1.2 *) (** {2 Utils} *) diff --git a/tests/core/t_string.ml b/tests/core/t_string.ml index 9cf08e270..b850dbc6f 100644 --- a/tests/core/t_string.ml +++ b/tests/core/t_string.ml @@ -20,6 +20,8 @@ eq' 6 (find ~start:5 ~sub:"a" "a1a234a");; q ~count:10_000 Q.(pair string_printable string_printable) (fun (s1, s2) -> + s2 = "" + || let i = find ~sub:s2 s1 in i < 0 || String.sub s1 i (length s2) = s2) @@ -47,6 +49,8 @@ eq' 6 (rfind ~sub:"a" "a1a234a");; q ~count:10_000 Q.(pair string_printable string_printable) (fun (s1, s2) -> + s2 = "" + || let i = rfind ~sub:s2 s1 in i < 0 || String.sub s1 i (length s2) = s2) ;; From cc3a7d729a1b41f7ccd2aa5e1c305d38cc8a5ece Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Jun 2026 15:04:25 -0400 Subject: [PATCH 2/5] more tests for strings --- tests/core/t_string.ml | 68 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/tests/core/t_string.ml b/tests/core/t_string.ml index b850dbc6f..92207e896 100644 --- a/tests/core/t_string.ml +++ b/tests/core/t_string.ml @@ -53,6 +53,74 @@ q ~count:10_000 || let i = rfind ~sub:s2 s1 in i < 0 || String.sub s1 i (length s2) = s2) + +(* Compare the KMP-based search against a naive reference, over a 2-char + alphabet so that needles actually occur in the haystack. This is a + two-sided check: it catches false negatives, wrong (non-leftmost/rightmost) + positions, and missed overlapping matches — none of which the properties + above (one-sided, large alphabet) can see. Needles can be longer than the + haystack (exercising the short-circuit) and repetitive (exercising the + failure table). *) +let gen_ab ~maxlen = + Q.Gen.( + string_size (int_range 0 maxlen) + ~gen:(fun st -> if Random.State.bool st then 'a' else 'b')) + +let arb_haystack = Q.make ~print:Q.Print.string (gen_ab ~maxlen:20) +let arb_needle = Q.make ~print:Q.Print.string (gen_ab ~maxlen:6) + +module Find_ = struct + let naive_find ~sub s = + let n = String.length sub and ls = String.length s in + let rec loop i = + if i + n > ls then + -1 + else if String.equal (String.sub s i n) sub then + i + else + loop (i + 1) + in + loop 0 + + let naive_rfind ~sub s = + let n = String.length sub and ls = String.length s in + let rec loop i = + if i < 0 then + -1 + else if String.equal (String.sub s i n) sub then + i + else + loop (i - 1) + in + loop (ls - n) + + let naive_find_all ~sub s = + let n = String.length sub and ls = String.length s in + let rec loop i acc = + if i + n > ls then + List.rev acc + else if String.equal (String.sub s i n) sub then + loop (i + 1) (i :: acc) + else + loop (i + 1) acc + in + loop 0 [] +end +;; + +q ~count:10_000 ~name:"naive1" + Q.(pair arb_haystack arb_needle) + (fun (s, sub) -> Q.assume (sub <> ""); find ~sub s = Find_.naive_find ~sub s) +;; + +q ~count:10_000 ~name:"naive2" + Q.(pair arb_haystack arb_needle) + (fun (s, sub) -> Q.assume (sub <> ""); rfind ~sub s = Find_.naive_rfind ~sub s) +;; + +q ~count:10_000 ~name:"naive3" + Q.(pair arb_haystack arb_needle) + (fun (s, sub) -> Q.assume (sub <> ""); find_all_l ~sub s = Find_.naive_find_all ~sub s) ;; eq ~printer:CCFun.id From b147fe9b0a00d8e973b71bf8e4b7d95ecae171f2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Jun 2026 15:04:33 -0400 Subject: [PATCH 3/5] KMP benchs --- benchs/run_benchs.ml | 166 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 166 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index dddf908ed..b20fa08ec 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1636,6 +1636,159 @@ module Str = struct assert (CCList.equal CCInt.equal (mk_naive ()) (mk_current ())); B.throughputN 3 ~repeat [ "naive", mk_naive, (); "current", mk_current, () ] + (* Inlined reference implementations to have a fixpoint to compae + CCString with. + + - [Classic_kmp] is a copy of CCString's old KMP: the + basic ("weak") failure table and the window-shift search loop. + - [New_kmp] is a bit optimized. *) + module Classic_kmp = struct + type t = { + failure: int array; + pat: string; + } + + let compile pat = + let len = String.length pat in + match len with + | 0 -> { failure = [||]; pat } + | 1 -> { failure = [| -1 |]; pat } + | _ -> + let failure = Array.make len 0 in + failure.(0) <- -1; + let i = ref 2 and j = ref 0 in + while !i < len do + if CCChar.equal pat.[!i - 1] pat.[!j] then ( + incr j; + failure.(!i) <- !j; + incr i + ) else if !j = 0 then ( + failure.(!i) <- 0; + incr i + ) else + j := failure.(!j) + done; + { failure; pat } + + let find { failure; pat } s = + let len = String.length s in + let i = ref 0 and j = ref 0 in + let pat_len = String.length pat in + while !j < pat_len && !i + !j < len do + if CCChar.equal s.[!i + !j] pat.[!j] then + incr j + else ( + let fail_offset = failure.(!j) in + if fail_offset >= 0 then ( + assert (fail_offset < !j); + i := !i + !j - fail_offset; + j := fail_offset + ) else ( + j := 0; + incr i + ) + ) + done; + if !j = pat_len then + !i + else + -1 + end + + module New_kmp = struct + type t = { + failure: int array; + pat: string; + } + + let compile pat = + let len = String.length pat in + match len with + | 0 -> { failure = [||]; pat } + | 1 -> { failure = [| -1 |]; pat } + | _ -> + let failure = Array.make len 0 in + failure.(0) <- -1; + let i = ref 2 and j = ref 0 in + while !i < len do + if CCChar.equal pat.[!i - 1] pat.[!j] then ( + incr j; + failure.(!i) <- !j; + incr i + ) else if !j = 0 then ( + failure.(!i) <- 0; + incr i + ) else + j := failure.(!j) + done; + (* strengthen: if the char after the border equals the one we'd be + retrying, skip straight to that border's (already-strengthened) + target instead of re-comparing it and failing again *) + for k = 1 to len - 1 do + let b = failure.(k) in + if b >= 0 && CCChar.equal pat.[k] pat.[b] then + failure.(k) <- failure.(b) + done; + { failure; pat } + + let find { failure; pat } s = + let len = String.length s in + let i = ref 0 and j = ref 0 in + let pat_len = String.length pat in + while !j < pat_len && !i + !j < len do + if CCChar.equal s.[!i + !j] pat.[!j] then + incr j + else ( + let fail_offset = failure.(!j) in + if fail_offset >= 0 then ( + assert (fail_offset < !j); + i := !i + !j - fail_offset; + j := fail_offset + ) else ( + (* no usable border: advance past the mismatch (NOT [incr i]) *) + i := !i + !j + 1; + j := 0 + ) + ) + done; + if !j = pat_len then + !i + else + -1 + end + + (* a worst case test to show the difference between classic and new KMP, + with a needle [a^size] searched in a haystack made of [a^(size-1)b] + blocks. *) + let bench_find_special ~size n = + let needle = String.make size 'a' in + let block = String.make (size - 1) 'a' ^ "b" in + let haystack = CCString.repeat block (n / size) in + pp_pb needle haystack; + let classic = Classic_kmp.compile needle in + let strong = New_kmp.compile needle in + let cur = CCString.find ~start:0 ~sub:needle in + let mk_naive () = find ~sub:needle haystack + and mk_classic () = Classic_kmp.find classic haystack + and mk_new () = New_kmp.find strong haystack + and mk_cur () = cur haystack in + assert (mk_naive () = -1); + assert (mk_classic () = -1); + assert (mk_new () = -1); + assert (mk_cur () = -1); + (* positive control: a haystack that does contain the needle *) + let with_match = haystack ^ needle in + let expected = CCString.find ~sub:needle with_match in + assert (Classic_kmp.find classic with_match = expected); + assert (New_kmp.find strong with_match = expected); + B.throughputN 2 ~repeat + [ + "naive", mk_naive, (); + "classic", mk_classic, (); + "new", mk_new, (); + "cur", mk_cur, (); + ] + let bench_find = bench_find_ ~dir:`Direct let bench_rfind = bench_find_ ~dir:`Reverse @@ -1757,6 +1910,19 @@ module Str = struct @>> app_ints (bench_find ~size:50) [ 100; 100_000; 500_000 ]; "500" @>> app_ints (bench_find ~size:500) [ 100_000; 500_000 ]; + (* short haystack, long needle: needle (500) longer than + haystack, so the lazy failure table is never built *) + "500_short" + @>> app_ints (bench_find ~size:500) [ 50; 100 ]; + ]; + "find_special" + @>>> [ + "100" + @>> app_ints (bench_find_special ~size:100) + [ 200_000; 1_000_000 ]; + "1000" + @>> app_ints (bench_find_special ~size:1000) + [ 200_000; 1_000_000 ]; ]; "find_all" @>>> [ From ff51885abb585b47a5ad4efd3f293a5470f5c79f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Jun 2026 15:17:10 -0400 Subject: [PATCH 4/5] perf ccstring: stronger KMP with delayed compilation, and strenghten failure condition --- src/core/CCString.ml | 68 +++++++++++++++++++++++++++++++++----------- 1 file changed, 51 insertions(+), 17 deletions(-) diff --git a/src/core/CCString.ml b/src/core/CCString.ml index 76b22e3b1..26e6e54a7 100644 --- a/src/core/CCString.ml +++ b/src/core/CCString.ml @@ -45,11 +45,12 @@ type _ direction = (* we follow https://en.wikipedia.org/wiki/Knuth–Morris–Pratt_algorithm *) module Find = struct type 'a kmp_pattern = { - failure: int array; + mutable failure: int array; (* empty=not computed yet *) str: string; + dir: 'a direction; } - (* invariant: [length failure = length str]. - We use a phantom type to avoid mixing the directions. *) + (* invariant: [failure=[||] || length failure = length str]. + The failure table is built lazily, we bypass it if len(haystack) String.get | Reverse -> fun s i -> s.[String.length s - i - 1] - let kmp_compile_ : type a. dir:a direction -> string -> a kmp_pattern = + (* build the KMP failure table for [str], whose elements are read + according to [dir] *) + let kmp_failure_ : type a. dir:a direction -> string -> int array = fun ~dir str -> let len = length str in let get = get_ ~dir in (* how to read elements of the string *) match len with - | 0 -> { failure = [||]; str } - | 1 -> { failure = [| -1 |]; str } + | 0 -> [||] + | 1 -> [| -1 |] | _ -> (* at least 2 elements, the algorithm can work *) let failure = Array.make len 0 in @@ -93,7 +96,26 @@ module Find = struct j := failure.(!j) done; (* Format.printf "{@[failure:%a, str:%s@]}@." CCFormat.(array int) failure str; *) - { failure; str } + + (* strengthen the failure function: if falling back to a border would + re-compare a character equal to the one that just mismatched, skip + straight to that border's (already-strengthened) target instead. + Uses the direction-aware [get] so it works for both directions. *) + for k = 1 to len - 1 do + let b = failure.(k) in + if b >= 0 && CCChar.equal (get str k) (get str b) then + failure.(k) <- failure.(b) + done; + failure + + let kmp_compile_ : type a. dir:a direction -> string -> a kmp_pattern = + fun ~dir str -> { str; failure = [||]; dir } + + let[@inline] kmp_get_ (type a) (f: a kmp_pattern) : int array = + if Array.length f.failure = 0 then ( + f.failure <- kmp_failure_ ~dir:f.dir f.str; + ); + f.failure let kmp_compile s = kmp_compile_ ~dir:Direct s let kmp_rcompile s = kmp_compile_ ~dir:Reverse s @@ -107,6 +129,7 @@ module Find = struct let i = ref idx in let j = ref 0 in let pat_len = kmp_pattern_length pattern in + let failure = kmp_get_ pattern in while !j < pat_len && !i + !j < len do let c = String.get s (!i + !j) in let expected = String.get pattern.str !j in @@ -114,16 +137,16 @@ module Find = struct (* char matches *) incr j else ( - let fail_offset = pattern.failure.(!j) in + let fail_offset = failure.(!j) in if fail_offset >= 0 then ( assert (fail_offset < !j); (* follow the failure link *) i := !i + !j - fail_offset; j := fail_offset ) else ( - (* beginning of pattern *) - j := 0; - incr i + (* no usable border: advance past the mismatch *) + i := !i + !j + 1; + j := 0 ) ) done; @@ -141,6 +164,7 @@ module Find = struct let i = ref (len - idx - 1) in let j = ref 0 in let pat_len = kmp_pattern_length pattern in + let failure = kmp_get_ pattern in while !j < pat_len && !i + !j < len do let c = String.get s (len - !i - !j - 1) in let expected = @@ -150,16 +174,16 @@ module Find = struct (* char matches *) incr j else ( - let fail_offset = pattern.failure.(!j) in + let fail_offset = failure.(!j) in if fail_offset >= 0 then ( assert (fail_offset < !j); (* follow the failure link *) i := !i + !j - fail_offset; j := fail_offset ) else ( - (* beginning of pattern *) - j := 0; - incr i + (* no usable border: advance past the mismatch *) + i := !i + !j + 1; + j := 0 ) ) done; @@ -197,7 +221,12 @@ module Find = struct let find ?(start = 0) ~(pattern : [ `Direct ] pattern) s = match pattern with | P_char c -> (try String.index_from s start c with Not_found -> -1) - | P_KMP pattern -> kmp_find ~pattern s start + | P_KMP pattern -> + (* haystack too short, bail out without forcing kmp state *) + if String.length s - start < kmp_pattern_length pattern then + -1 + else + kmp_find ~pattern s start let rfind ?start ~(pattern : [ `Reverse ] pattern) s = let start = @@ -207,7 +236,12 @@ module Find = struct in match pattern with | P_char c -> (try String.rindex_from s start c with Not_found -> -1) - | P_KMP pattern -> kmp_rfind ~pattern s start + | P_KMP pattern -> + (* haystack too short, bail out without forcing kmp state *) + if start + 1 < kmp_pattern_length pattern then + -1 + else + kmp_rfind ~pattern s start end let find ?(start = 0) ~sub = From 43b9306cec08ecaa0ca640173f031a70f4c27860 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Jun 2026 19:17:53 +0000 Subject: [PATCH 5/5] format --- benchs/run_benchs.ml | 9 +++++---- src/core/CCString.ml | 8 ++++---- tests/core/t_string.ml | 19 ++++++++++++++----- 3 files changed, 23 insertions(+), 13 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index b20fa08ec..e9c8084d9 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1912,16 +1912,17 @@ module Str = struct @>> app_ints (bench_find ~size:500) [ 100_000; 500_000 ]; (* short haystack, long needle: needle (500) longer than haystack, so the lazy failure table is never built *) - "500_short" - @>> app_ints (bench_find ~size:500) [ 50; 100 ]; + "500_short" @>> app_ints (bench_find ~size:500) [ 50; 100 ]; ]; "find_special" @>>> [ "100" - @>> app_ints (bench_find_special ~size:100) + @>> app_ints + (bench_find_special ~size:100) [ 200_000; 1_000_000 ]; "1000" - @>> app_ints (bench_find_special ~size:1000) + @>> app_ints + (bench_find_special ~size:1000) [ 200_000; 1_000_000 ]; ]; "find_all" diff --git a/src/core/CCString.ml b/src/core/CCString.ml index 26e6e54a7..7ceb95408 100644 --- a/src/core/CCString.ml +++ b/src/core/CCString.ml @@ -95,6 +95,7 @@ module Find = struct assert (!j > 0); j := failure.(!j) done; + (* Format.printf "{@[failure:%a, str:%s@]}@." CCFormat.(array int) failure str; *) (* strengthen the failure function: if falling back to a border would @@ -109,12 +110,11 @@ module Find = struct failure let kmp_compile_ : type a. dir:a direction -> string -> a kmp_pattern = - fun ~dir str -> { str; failure = [||]; dir } + fun ~dir str -> { str; failure = [||]; dir } - let[@inline] kmp_get_ (type a) (f: a kmp_pattern) : int array = - if Array.length f.failure = 0 then ( + let[@inline] kmp_get_ (type a) (f : a kmp_pattern) : int array = + if Array.length f.failure = 0 then f.failure <- kmp_failure_ ~dir:f.dir f.str; - ); f.failure let kmp_compile s = kmp_compile_ ~dir:Direct s diff --git a/tests/core/t_string.ml b/tests/core/t_string.ml index 92207e896..4f13f8310 100644 --- a/tests/core/t_string.ml +++ b/tests/core/t_string.ml @@ -63,8 +63,11 @@ q ~count:10_000 failure table). *) let gen_ab ~maxlen = Q.Gen.( - string_size (int_range 0 maxlen) - ~gen:(fun st -> if Random.State.bool st then 'a' else 'b')) + string_size (int_range 0 maxlen) ~gen:(fun st -> + if Random.State.bool st then + 'a' + else + 'b')) let arb_haystack = Q.make ~print:Q.Print.string (gen_ab ~maxlen:20) let arb_needle = Q.make ~print:Q.Print.string (gen_ab ~maxlen:6) @@ -110,17 +113,23 @@ end q ~count:10_000 ~name:"naive1" Q.(pair arb_haystack arb_needle) - (fun (s, sub) -> Q.assume (sub <> ""); find ~sub s = Find_.naive_find ~sub s) + (fun (s, sub) -> + Q.assume (sub <> ""); + find ~sub s = Find_.naive_find ~sub s) ;; q ~count:10_000 ~name:"naive2" Q.(pair arb_haystack arb_needle) - (fun (s, sub) -> Q.assume (sub <> ""); rfind ~sub s = Find_.naive_rfind ~sub s) + (fun (s, sub) -> + Q.assume (sub <> ""); + rfind ~sub s = Find_.naive_rfind ~sub s) ;; q ~count:10_000 ~name:"naive3" Q.(pair arb_haystack arb_needle) - (fun (s, sub) -> Q.assume (sub <> ""); find_all_l ~sub s = Find_.naive_find_all ~sub s) + (fun (s, sub) -> + Q.assume (sub <> ""); + find_all_l ~sub s = Find_.naive_find_all ~sub s) ;; eq ~printer:CCFun.id