Compile character range patterns in linear time (#8868)

Why:
    A character range pattern is expanded into one or-pattern alternative
    per character, and typing, the exhaustiveness and unused-case checks,
    default matrices and switch compilation each took time quadratic in
    the number of alternatives: a range over the CJK block ran out of
    memory (#8866).

Matching modified (character range patterns):
Example:
    let f = c =>
      switch c {
      | '\u{100}' .. '\u{1100}' => 1
      | _ => 0
      }
Before (lambda):
    (let
      (f/1001 =
         (function c/1002
           (catch
             (catch
               (if (|| (>[int] c/1002 4352) (<[int] c/1002 256)) (exit 2)
                 (exit 1))
              with (2) 0)
            with (1) 1)))
      (makeblock module/exports f/1001))
After (lambda):
    (let
      (f/1001 =
         (function c/1002
           (catch
             (catch
               (if (|| (>[int] c/1002 4352) (<[int] c/1002 256)) (exit 2)
                 (exit 1))
              with (2) 0)
            with (1) 1)))
      (makeblock module/exports f/1001))
Before (text): `/usr/bin/time -l bsc` on the example, three runs
            2.22 real         2.03 user         0.18 sys
              1273511936  maximum resident set size
            2.20 real         2.02 user         0.16 sys
              1271463936  maximum resident set size
            2.21 real         2.03 user         0.17 sys
              1273659392  maximum resident set size
After (text): `/usr/bin/time -l bsc` on the example, three runs
            0.02 real         0.02 user         0.00 sys
                25395200  maximum resident set size
            0.02 real         0.02 user         0.00 sys
                25624576  maximum resident set size
            0.03 real         0.02 user         0.00 sys
                25591808  maximum resident set size

Review: Where did the time go? Typing copied the right subtree of each
    nested or-pattern to rename variables even when there are none; the
    checks searched the groups linearly for each row and compared all
    pairs of rows for the default matrix minima; switch compilation found
    each key's cell with `List.find`. Groups, minima and int, char and
    string cells are now found by hashing, and the copy is skipped when
    nothing is renamed.

Review: Does the generated code change? No: #8868 reports byte-identical
    JavaScript and warnings across `tests/tests/src`, the `super_errors`
    fixtures and the runtime.

Re-applies #8868 by @cknitt for illustration.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
Signed-off-by: Cristiano Calcagno <cristianoc@users.noreply.github.com>

Author: cristianoc

changes/linear-char-range-patterns.fix.md

@@ -0,0 +1 @@
+- Fix quadratic compile time and memory of large character range patterns, and speed up switches over many constants. https://github.com/rescript-lang/rescript/pull/8868

compiler/ml/matching.ml

@@ -621,7 +621,7 @@ let rec what_is_cases cases =
   | _ -> assert false
 
 (* A few operations on default environments *)
-let as_matrix cases = get_mins le_pats (List.map (fun (ps, _) -> ps) cases)
+let as_matrix cases = get_mins_pats (List.map (fun (ps, _) -> ps) cases)
 
 let cons_default matrix raise_num default =
   match matrix with
@@ -1147,13 +1147,28 @@ let add make_matching_fun division eq_key key patl_action args =
     cell.pm.cases <- [patl_action];
     (key, cell) :: division
 
-let divide make eq_key get_key get_args ctx pm =
+(* Cells whose key is [hashable] are also found by hashing, which must agree
+   with [eq_key]. This keeps a column of many distinct keys linear. *)
+let divide ?(hashable = fun _ -> false) make eq_key get_key get_args ctx pm =
+  let cells = lazy (Hashtbl.create 16) in
   let rec divide_rec = function
-    | (p :: patl, action) :: rem ->
+    | (p :: patl, action) :: rem -> (
       let this_match = divide_rec rem in
-      add (make p pm.default ctx) this_match eq_key (get_key p)
-        (get_args p patl, action)
-        pm.args
+      let key = get_key p in
+      let patl_action = (get_args p patl, action) in
+      if not (hashable key) then
+        add (make p pm.default ctx) this_match eq_key key patl_action pm.args
+      else
+        let cells = Lazy.force cells in
+        match Hashtbl.find_opt cells key 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 key cell;
+          (key, cell) :: this_match)
     | _ -> []
   in
 
@@ -1210,7 +1225,11 @@ let make_constant_matching p def ctx = function
     {pm = {cases = []; args = argl; default = def}; ctx; pat = normalize_pat p}
 
 let divide_constant ctx m =
-  divide make_constant_matching
+  divide
+    ~hashable:(function
+      | Asttypes.Const_int _ | Const_char _ | Const_string _ -> true
+      | Const_float _ | Const_bigint _ -> false)
+    make_constant_matching
     (fun c d -> const_compare c d = 0)
     (get_key_constant "divide")
     get_args_constant ctx m

compiler/ml/parmatch.ml

@@ -730,26 +730,61 @@ let filter_extra pss =
 *)
 
 let filter_all pat0 pss =
-  let rec insert q qs env =
-    match env with
-    | [] ->
-      let q0 = normalize_pat q in
-      [(q0, [simple_match_args q0 q @ qs])]
-    | ((q0, pss) as c) :: env ->
-      if simple_match q0 q then
-        (q0, (simple_match_args q0 q @ qs) :: pss) :: env
-      else c :: insert q qs env
+  (* 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. *)
+  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 variant_groups = lazy (Hashtbl.create 16) in
+  let add_row (q0, rows) q qs =
+    rows := (simple_match_args q0 q @ qs) :: !rows
+  in
+  let new_group q qs =
+    let q0 = normalize_pat q in
+    let group = (q0, ref []) in
+    add_row group q qs;
+    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)
+  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 c 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))
   in
 
-  let rec filter_rec env = function
+  let rec filter_rec = function
     | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss ->
-      filter_rec env ((p :: ps) :: pss)
+      filter_rec ((p :: ps) :: pss)
     | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss ->
-      filter_rec env ((p1 :: ps) :: (p2 :: ps) :: pss)
-    | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> filter_rec env pss
-    | (p :: ps) :: pss -> filter_rec (insert p ps env) pss
-    | _ -> env
-  and filter_omega env = function
+      filter_rec ((p1 :: ps) :: (p2 :: ps) :: pss)
+    | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> filter_rec pss
+    | (p :: ps) :: pss ->
+      insert p ps;
+      filter_rec pss
+    | _ -> ()
+  in
+  let rec filter_omega env = function
     | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss ->
       filter_omega env ((p :: ps) :: pss)
     | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss ->
@@ -764,13 +799,8 @@ let filter_all pat0 pss =
     | [] -> env
   in
 
-  filter_omega
-    (filter_rec
-       (match pat0.pat_desc with
-       | Tpat_record _ | Tpat_tuple _ -> [(pat0, [])]
-       | _ -> [])
-       pss)
-    pss
+  filter_rec pss;
+  filter_omega (List.rev_map (fun (q0, rows) -> (q0, !rows)) !groups) pss
 
 (* Variant related functions *)
 
@@ -1672,6 +1702,49 @@ 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 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
@@ -2117,7 +2190,7 @@ let check_unused pred casel =
       | {c_lhs = q; c_guard} :: rem ->
         let qs = [q] in
         (try
-           let pss = get_mins le_pats (Ext_list.filter pref (compats qs)) in
+           let pss = get_mins_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 -> .] *)
@@ -2196,7 +2269,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 le_pats pss in
+  let pss = get_mins_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

@@ -49,6 +49,7 @@ 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/typecore.ml

@@ -1762,8 +1762,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
         in
         pattern_variables_ref () := p1_variables;
         module_variables_ref () := p1_module_variables;
+        (* Without variables there is nothing to rename. Skipping the copy
+           keeps nested or-patterns, e.g. expanded character ranges, linear. *)
+        let p2 = if alpha_env = [] then p2 else alpha_pat alpha_env p2 in
         {
-          pat_desc = Tpat_or (p1, alpha_pat alpha_env p2, None);
+          pat_desc = Tpat_or (p1, p2, None);
           pat_loc = loc;
           pat_extra = [];
           pat_type = expected_ty;

tests/tests/src/char_range_test.mjs

@@ -0,0 +1,64 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as Mocha from "mocha";
+import * as Test_utils from "./test_utils.mjs";
+
+function isCjk(c) {
+  return !(c > 40959 || c < 19968);
+}
+
+function classify(c) {
+  if (c >= 95) {
+    if (c < 123) {
+      if (c !== 96) {
+        if (c >= 96) {
+          return "lower";
+        } else {
+          return "word";
+        }
+      } else {
+        return "other";
+      }
+    } else if (c > 65535 || c < 256) {
+      return "other";
+    } else {
+      return "bmp";
+    }
+  } else if (c >= 58) {
+    if (c > 90 || c < 65) {
+      return "other";
+    } else {
+      return "upper";
+    }
+  } else if (c >= 48) {
+    return "word";
+  } else {
+    return "other";
+  }
+}
+
+Mocha.describe("Char_range_test", () => {
+  Mocha.test("large range", () => {
+    Test_utils.eq("File \"char_range_test.res\", line 23, characters 7-14", false, false);
+    Test_utils.eq("File \"char_range_test.res\", line 24, characters 7-14", true, true);
+    Test_utils.eq("File \"char_range_test.res\", line 25, characters 7-14", true, true);
+    Test_utils.eq("File \"char_range_test.res\", line 26, characters 7-14", true, true);
+    Test_utils.eq("File \"char_range_test.res\", line 27, characters 7-14", false, false);
+  });
+  Mocha.test("several ranges", () => {
+    Test_utils.eq("File \"char_range_test.res\", line 31, characters 7-14", classify(/* 'q' */113), "lower");
+    Test_utils.eq("File \"char_range_test.res\", line 32, characters 7-14", classify(/* 'Q' */81), "upper");
+    Test_utils.eq("File \"char_range_test.res\", line 33, characters 7-14", classify(/* '7' */55), "word");
+    Test_utils.eq("File \"char_range_test.res\", line 34, characters 7-14", classify(/* '_' */95), "word");
+    Test_utils.eq("File \"char_range_test.res\", line 35, characters 7-14", classify(/* 'ō' */333), "bmp");
+    Test_utils.eq("File \"char_range_test.res\", line 36, characters 7-14", classify(/* '￿' */65535), "bmp");
+    Test_utils.eq("File \"char_range_test.res\", line 37, characters 7-14", classify(/* '𐀀' */65536), "other");
+    Test_utils.eq("File \"char_range_test.res\", line 38, characters 7-14", classify(/* '!' */33), "other");
+  });
+});
+
+export {
+  isCjk,
+  classify,
+}
+/*  Not a pure module */

tests/tests/src/char_range_test.res

@@ -0,0 +1,40 @@
+open Mocha
+open Test_utils
+
+// A range is expanded into one alternative per character. This one has about
+// 21,000, which used to take a minute and many GB of memory to compile.
+let isCjk = c =>
+  switch c {
+  | '\u{4E00}' .. '\u{9FFF}' => true
+  | _ => false
+  }
+
+let classify = c =>
+  switch c {
+  | 'a' .. 'z' => "lower"
+  | 'A' .. 'Z' => "upper"
+  | '0' .. '9' | '_' => "word"
+  | '\u{100}' .. '\u{FFFF}' => "bmp"
+  | _ => "other"
+  }
+
+describe(__MODULE__, () => {
+  test("large range", () => {
+    eq(__LOC__, isCjk('\u{4DFF}'), false)
+    eq(__LOC__, isCjk('\u{4E00}'), true)
+    eq(__LOC__, isCjk('中'), true)
+    eq(__LOC__, isCjk('\u{9FFF}'), true)
+    eq(__LOC__, isCjk('\u{A000}'), false)
+  })
+
+  test("several ranges", () => {
+    eq(__LOC__, classify('q'), "lower")
+    eq(__LOC__, classify('Q'), "upper")
+    eq(__LOC__, classify('7'), "word")
+    eq(__LOC__, classify('_'), "word")
+    eq(__LOC__, classify('ō'), "bmp")
+    eq(__LOC__, classify('\u{FFFF}'), "bmp")
+    eq(__LOC__, classify('\u{10000}'), "other")
+    eq(__LOC__, classify('!'), "other")
+  })
+})