Compile character range patterns in linear time

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

@@ -1763,8 +1763,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")
+  })
+})