From c8313d5b7847c991f61bbb12cd3a3144b20a66c9 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 18 Oct 2026 17:52:36 +0000 Subject: [PATCH] Remove the hashing fast paths from pattern matching #8868 made exhaustiveness checking and match compilation find constants by hashing, because an expanded char range turned one pattern into thousands of distinct constants. Char ranges are now one pattern each, so the hash tables in `Parmatch.filter_all`, `Parmatch.get_mins_pats` and `Matching.divide`, and the `const_key` that kept their keys consistent with char/int equality, are removed. A dead `char` check in comparison specialization goes too: `char` expands to `int` before it. Review: How much slower do large switches compile? A switch with 1,000 int or string cases compiles 0.02-0.03 s slower; one with 10,000 int cases takes 6.3 s instead of 3.2 s. Polymorphic variants are unaffected: 10,000 cases take about 35 s either way, as other quadratic steps dominate. Review: Does the output change? No. All committed snapshots are byte-identical, and so is the JS of 1,500 fuzzer programs and the benchmark switches. Area: typechecker lambda Output: unchanged Formatting: unchanged Formats: none PPX: unchanged Editor: unchanged Tests: none, because the output is unchanged and existing tests cover the behaviour Measured: best of 3 bsc wall time, with -> without the fast paths: 1,000 int cases 0.07 -> 0.09 s; 3,000 int 0.34 -> 0.63 s; 10,000 int 3.23 -> 6.27 s; 1,000 string 0.04 -> 0.07 s; 3,000 string 0.17 -> 0.52 s; 10,000 string 1.55 -> 5.38 s; 1,000 polymorphic variant 0.23 -> 0.25 s; 10,000 polymorphic variant 35.47 -> 36.45 s Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01JALXUyHhkDqzcB3WuW9Svo Signed-off-by: Christoph Knittel --- changes/remove-match-fast-paths.internal.md | 1 + compiler/ml/matching.ml | 36 ++------- compiler/ml/parmatch.ml | 90 +++------------------ compiler/ml/parmatch.mli | 4 - compiler/ml/translcore.ml | 1 - 5 files changed, 21 insertions(+), 111 deletions(-) create mode 100644 changes/remove-match-fast-paths.internal.md diff --git a/changes/remove-match-fast-paths.internal.md b/changes/remove-match-fast-paths.internal.md new file mode 100644 index 0000000000..5310320404 --- /dev/null +++ b/changes/remove-match-fast-paths.internal.md @@ -0,0 +1 @@ +- Remove the hashing fast paths for switches with many distinct constants, which char ranges no longer need. diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 71643a0ab5..feea30d6ab 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -631,7 +631,7 @@ let rec what_is_cases cases = | _ -> assert false (* A few operations on default environments *) -let as_matrix cases = get_mins_pats (List.map (fun (ps, _) -> ps) cases) +let as_matrix cases = get_mins le_pats (List.map (fun (ps, _) -> ps) cases) let cons_default matrix raise_num default = match matrix with @@ -1168,30 +1168,13 @@ let add make_matching_fun division eq_key key patl_action args = cell.pm.cases <- [patl_action]; (key, cell) :: division -(* Cells whose key has a [hash_key] are also found by hashing on it, which - must agree with [eq_key]. This keeps a column of many distinct keys - linear. *) -let divide ?(hash_key = fun _ -> None) make eq_key get_key get_args ctx pm = - let cells = lazy (Hashtbl.create 16) in +let divide make eq_key get_key get_args ctx pm = let rec divide_rec = function - | (p :: patl, action) :: rem -> ( + | (p :: patl, action) :: rem -> let this_match = divide_rec rem in - let key = get_key p in - let patl_action = (get_args p patl, action) in - match hash_key key with - | None -> - add (make p pm.default ctx) this_match eq_key key patl_action pm.args - | Some hkey -> ( - let cells = Lazy.force cells in - match Hashtbl.find_opt cells hkey with - | Some cell -> - cell.pm.cases <- patl_action :: cell.pm.cases; - this_match - | None -> - let cell = make p pm.default ctx pm.args in - cell.pm.cases <- [patl_action]; - Hashtbl.add cells hkey cell; - (key, cell) :: this_match)) + add (make p pm.default ctx) this_match eq_key (get_key p) + (get_args p patl, action) + pm.args | _ -> [] in @@ -1342,12 +1325,7 @@ let divide_constant ctx m = match column_int_ranges m with | Some ranges -> divide_constant_ranges ranges ctx m | None -> - divide - ~hash_key:(function - | ((Asttypes.Const_int _ | Const_char _ | Const_string _) as c), _ -> - Some (Parmatch.const_key c) - | (Const_float _ | Const_bigint _), _ -> None) - make_constant_matching + divide make_constant_matching (fun (c, _) (d, _) -> const_compare c d = 0) (get_key_constant "divide") get_args_constant ctx m diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index b2eaf36a6a..15557ec177 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -325,12 +325,6 @@ let const_compare x y = compare i1 i2 | _, _ -> compare x y -(* [char] is an alias of [int], so a char constant and an int constant with the - same value match the same values. Hash tables of constants use this key. *) -let const_key = function - | Const_char i -> Const_int i - | c -> c - let records_args l1 l2 = (* Invariant: fields are already sorted by Typecore.type_record_elem_list *) let rec combine r1 r2 l1 l2 = @@ -804,22 +798,14 @@ let filter_extra pss = let filter_all pat0 pss = (* The groups, most recently created first. Each row goes to the group - whose head [simple_match]es it; there is at most one such group, since a - group is only created when no other matches. *) + whose head matches it; there is at most one such group, since a group is + only created when no other matches. *) let groups = ref (match pat0.pat_desc with | Tpat_record _ | Tpat_tuple _ -> [(pat0, ref [])] | _ -> []) in - (* For int, char and string constants and for polymorphic variants, - [simple_match] is equality, so their groups are also found by hashing. - This keeps a column of many distinct heads, e.g. an expanded character - range, linear instead of quadratic. The tables are only created when needed, - as most calls are on small matrices. *) - let const_groups = lazy (Hashtbl.create 16) in - let interval_groups = lazy (Hashtbl.create 16) in - let variant_groups = lazy (Hashtbl.create 16) in let add_row (q0, rows) q qs = rows := (simple_match_args q0 q @ qs) :: !rows in @@ -830,24 +816,17 @@ let filter_all pat0 pss = groups := group :: !groups; group in - let find_or_add tbl key q qs = - let tbl = Lazy.force tbl in - match Hashtbl.find_opt tbl key with - | Some group -> add_row group q qs - | None -> Hashtbl.add tbl key (new_group q qs) + (* Int and char ranges are grouped by equal bounds, not by containment as + [simple_match] does, so that [build_other] sees every range. *) + let same_head q0 q = + match (int_range q0, int_range q) with + | Some r0, Some r -> r0 = r + | _ -> simple_match q0 q in let insert q qs = - match q.pat_desc with - | Tpat_constant ((Const_int _ | Const_char _ | Const_string _) as c) -> - find_or_add const_groups (const_key c) q qs - | Tpat_interval (c1, c2) -> - (* Grouped by equal bounds; [build_other] then sees every interval. *) - find_or_add interval_groups (const_key c1, const_key c2) q qs - | Tpat_variant (l, _, _) -> find_or_add variant_groups l q qs - | _ -> ( - match List.find_opt (fun (q0, _) -> simple_match q0 q) !groups with - | Some group -> add_row group q qs - | None -> ignore (new_group q qs)) + match List.find_opt (fun (q0, _) -> same_head q0 q) !groups with + | Some group -> add_row group q qs + | None -> ignore (new_group q qs) in let rec filter_rec = function @@ -1842,49 +1821,6 @@ let get_mins le ps = in select_rec [] (select_rec [] ps) -(* [get_mins le_pats pss], but faster for many rows starting with distinct - constants, e.g. an expanded character range. A row starting with an int, - char or string constant can only be covered by rows starting with the same - constant or with another kind of pattern, so only those are compared. *) -let get_mins_pats pss = - let key = function - | { - pat_desc = - Tpat_constant ((Const_int _ | Const_char _ | Const_string _) as c); - } - :: _ -> - Some (const_key c) - | _ -> None - in - (* [select_rec [] pss] of [get_mins le_pats]: drops each row covered by a - later row, and reverses the order. *) - let select pss = - let later = ref [] in - let later_by_key = lazy (Hashtbl.create 16) in - let later_unkeyed = ref [] in - let kept = - List.fold_left - (fun kept ps -> - let below qs = le_pats qs ps in - let key = key ps in - let dominated = - match key with - | None -> List.exists below !later - | Some c -> - List.exists below (Hashtbl.find_all (Lazy.force later_by_key) c) - || List.exists below !later_unkeyed - in - later := ps :: !later; - (match key with - | None -> later_unkeyed := ps :: !later_unkeyed - | Some c -> Hashtbl.add (Lazy.force later_by_key) c ps); - if dominated then kept else ps :: kept) - [] (List.rev pss) - in - List.rev kept - in - select (select pss) - (* lub p q is a pattern that matches all values matched by p and q may raise Empty, when p and q are not compatible @@ -2340,7 +2276,7 @@ let check_unused pred casel = | {c_lhs = q; c_guard} :: rem -> let qs = [q] in (try - let pss = get_mins_pats (Ext_list.filter pref (compats qs)) in + let pss = get_mins le_pats (Ext_list.filter pref (compats qs)) in (* First look for redundant or partially redundant patterns *) let r = every_satisfiables (make_rows pss) (make_row qs) in (* Do not warn for unused [pat -> .] *) @@ -2419,7 +2355,7 @@ let irrefutable pat = le_pat (Dict_pattern.lowering [pat] pat) omega let check_partial_param do_check_partial do_check_fragile loc casel = let pss = initial_matrix casel in - let pss = get_mins_pats pss in + let pss = get_mins le_pats pss in let total = do_check_partial loc casel pss in if total = Total && Warnings.is_active (Warnings.Fragile_match "") then do_check_fragile loc casel pss; diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli index 2fa7d16a3a..d7ad362797 100644 --- a/compiler/ml/parmatch.mli +++ b/compiler/ml/parmatch.mli @@ -34,9 +34,6 @@ val all_record_args : (Longident.t loc * label_description * pattern * bool) list val const_compare : constant -> constant -> int -(* A hash key agreeing with [const_compare]: char constants map to ints. *) -val const_key : constant -> constant - (* The bounds of an int or char constant or interval pattern *) val int_range : pattern -> (int * int) option @@ -59,7 +56,6 @@ val lub : pattern -> pattern -> pattern val lubs : pattern list -> pattern list -> pattern list val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list -val get_mins_pats : pattern list list -> pattern list list (* Those two functions recombine one pattern and its arguments: For instance: diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 80618a82a7..c3fc938625 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -401,7 +401,6 @@ let specialize_comparison match () with | () when is_base_type env ty Predef.path_int - || is_base_type env ty Predef.path_char || maybe_pointer_type env ty = Immediate -> intcomp | () when is_base_type env ty Predef.path_float -> floatcomp