Remove the hashing fast paths from pattern matching (#8900)

#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

Claude-Session: https://claude.ai/code/session_01JALXUyHhkDqzcB3WuW9Svo

Signed-off-by: Christoph Knittel <ck@cca.io>
Co-authored-by: Claude Opus 5.5 <noreply@anthropic.com>

Author: cknitt

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.

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

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;

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:

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