From 5d69ca2de92ab062d3f1d84bba23f3b1f41ad1ac Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 7 Nov 2026 10:11:47 +0000 Subject: [PATCH 1/2] Check large switches for unused cases without comparing every pair MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: The unused-case check compared each case with every earlier one and retyped part of each case, and its usefulness checks grouped rows by scanning all groups, so a switch with n constant or polymorphic variant cases cost O(n²) in several places: 6,000 int cases took 1.65 s and allocated 430M words, 1,600 polymorphic variant cases 1.31 s and 242M. They now take 0.56 s with 74M words, and 0.74 s with 128M. Rows are indexed by the constant or tag at their head, which a row can only share with rows of the same head or of a head without one, such as a wildcard or a range: the earlier rows compatible with a case, the groups of `filter_all` and the most general rows of `get_mins_pats` are found through that index. A case is retyped to find GADT cases that can't match only when its pattern has a GADT constructor, as no other pattern can fail to type. Warnings are the same for the test suites and 2,600 generated switches. Review: What remains superlinear? The match compiler (`Matching.divide` and the switch clustering) for constant switches: 6,000 int cases allocate 69M words with the warnings off, 3.4× the words for 3,000. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gK1dcjbe97yY1wRMgs Signed-off-by: Christoph Knittel --- changes/switch-unused-case-check.polish.md | 1 + compiler/ml/matching.ml | 2 +- compiler/ml/parmatch.ml | 156 ++++++++++++++++-- compiler/ml/parmatch.mli | 4 + .../warning_11_unused_constants.res.expected | 83 ++++++++++ .../fixtures/warning_11_unused_constants.res | 27 +++ 6 files changed, 260 insertions(+), 13 deletions(-) create mode 100644 changes/switch-unused-case-check.polish.md create mode 100644 tests/build_tests/super_errors/expected/warning_11_unused_constants.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/warning_11_unused_constants.res diff --git a/changes/switch-unused-case-check.polish.md b/changes/switch-unused-case-check.polish.md new file mode 100644 index 0000000000..e16c9e118a --- /dev/null +++ b/changes/switch-unused-case-check.polish.md @@ -0,0 +1 @@ +- Speed up the unused-case check of switches with many constant or polymorphic variant cases. diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index c42b9991bf..e7080f648a 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -640,7 +640,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 diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 5f0d0efc1f..5aa9221129 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -325,6 +325,29 @@ let const_compare x y = compare i1 i2 | _, _ -> compare x y +(* The head of a pattern when it is a constant or a polymorphic variant tag. + Two patterns with such heads are compatible, and one includes the other, + only when the heads are equal. *) +type head_key = Head_constant of constant | Head_variant of label + +let rec head_key p = + match p.pat_desc with + | Tpat_alias (p, _, _) -> head_key p + | Tpat_constant (Const_char i) -> Some (Head_constant (Const_int i)) + | Tpat_constant c -> Some (Head_constant c) + | Tpat_variant (l, _, _) -> Some (Head_variant l) + | _ -> None + +module Head_map = Map.Make (struct + type t = head_key + let compare k1 k2 = + match (k1, k2) with + | Head_constant c1, Head_constant c2 -> const_compare c1 c2 + | Head_variant l1, Head_variant l2 -> String.compare l1 l2 + | Head_constant _, Head_variant _ -> -1 + | Head_variant _, Head_constant _ -> 1 +end) + let records_args l1 l2 = (* Invariant: fields are already sorted by Typecore.type_record_elem_list *) let rec combine r1 r2 l1 l2 = @@ -809,11 +832,20 @@ let filter_all pat0 pss = let add_row (q0, rows) q qs = rows := (simple_match_args q0 q @ qs) :: !rows in + (* The groups again, those with a [head_key] by key: a row with a key + can only belong to the group of the same key, or to a group without one + (the range [5 .. 5] has the head of the constant [5]). Looking through + all groups for each row is quadratic in a switch on many constants. *) + let keyed = ref Head_map.empty in + let unkeyed = ref !groups 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; + (match head_key q0 with + | Some key -> keyed := Head_map.add key group !keyed + | None -> unkeyed := group :: !unkeyed); group in (* Int and char ranges are grouped by equal bounds, not by containment as @@ -824,7 +856,15 @@ let filter_all pat0 pss = | _ -> simple_match q0 q in let insert q qs = - match List.find_opt (fun (q0, _) -> same_head q0 q) !groups with + let group = + match head_key q with + | Some key -> ( + match Head_map.find_opt key !keyed with + | Some group -> Some group + | None -> List.find_opt (fun (q0, _) -> same_head q0 q) !unkeyed) + | None -> List.find_opt (fun (q0, _) -> same_head q0 q) !groups + in + match group with | Some group -> add_row group q qs | None -> ignore (new_group q qs) in @@ -1782,6 +1822,47 @@ let get_mins le ps = in select_rec [] (select_rec [] ps) +let row_head_key = function + | p :: _ -> head_key p + | [] -> None + +(* [get_mins le_pats pss], comparing a row with a [head_key] only with the + rows whose first pattern has the same key or none: comparing all pairs is + quadratic for a switch on many constants or tags. *) +let get_mins_pats pss = + (* The rows that no later row includes, in order. *) + let select pss = + let rec go keyed unkeyed kept = function + | [] -> kept + | ps :: rest -> + let includes ps0 = le_pats ps0 ps in + let key = row_head_key ps in + let included = + List.exists includes unkeyed + || + match key with + | Some key -> ( + match Head_map.find_opt key keyed with + | Some rows -> List.exists includes rows + | None -> false) + | None -> + Head_map.exists (fun _ rows -> List.exists includes rows) keyed + in + let keyed, unkeyed = + match key with + | Some key -> + ( Head_map.update key + (fun rows -> Some (ps :: Option.value rows ~default:[])) + keyed, + unkeyed ) + | None -> (keyed, ps :: unkeyed) + in + go keyed unkeyed (if included then kept else ps :: kept) rest + in + go Head_map.empty [] [] (List.rev pss) + in + List.rev (select (List.rev (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 @@ -2424,15 +2505,54 @@ let check_unused pred casel = if unused_match || Warnings.is_active (Warnings.Unused_pat "") then let casel = lower_cases casel in let dead_cases, already_reported = check_shadowed_payloads casel in - let rec do_rec pref = function + (* The earlier rows, most recent first, numbered from 0, and grouped by + [head_key]: a case with a key is only compatible with the rows of the + same key and the rows without one. *) + let rec merge_rows acc rows1 rows2 = + match (rows1, rows2) with + | [], rows | rows, [] -> List.rev_append acc (List.map snd rows) + | (i1, ps1) :: rest1, (i2, _) :: _ when i1 > i2 -> + merge_rows (ps1 :: acc) rest1 rows2 + | _, (_, ps2) :: rest2 -> merge_rows (ps2 :: acc) rows1 rest2 + in + let compatible_rows qs (pref, keyed, unkeyed) = + match row_head_key qs with + | None -> Ext_list.filter (List.map snd pref) (compats qs) + | Some key -> + let keyed = + match Head_map.find_opt key keyed with + | Some rows -> rows + | None -> [] + in + Ext_list.filter (merge_rows [] keyed unkeyed) (compats qs) + in + let add_row qs (pref, keyed, unkeyed) = + let index = + match pref with + | (index, _) :: _ -> index + 1 + | [] -> 0 + in + let row = (index, qs) in + let pref = row :: pref in + match row_head_key qs with + | Some key -> + ( pref, + Head_map.update key + (fun rows -> Some (row :: Option.value rows ~default:[])) + keyed, + unkeyed ) + | None -> (pref, keyed, row :: unkeyed) + in + let rec do_rec rows = function | [] -> () | case :: rem when List.memq case dead_cases -> (* A case that matches nothing cannot make later cases unused *) - do_rec pref rem + do_rec rows rem | {c_lhs = q; c_guard} :: rem -> let qs = [q] in + let pref, _, _ = rows in (try - let pss = get_mins le_pats (Ext_list.filter pref (compats qs)) in + let pss = get_mins_pats (compatible_rows qs rows) 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 -> .] *) @@ -2472,11 +2592,22 @@ let check_unused pred casel = (*Format.eprintf "%a@." pretty_val u;*) let pattern, constrs, labels = Conv.conv u in let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in - match pred constrs labels pattern with - | None -> - Location.prerr_warning q.pat_loc Warnings.Unreachable_case; - Used - | _ -> r + (* Only a GADT constructor can make a pattern built from + the case's own subpatterns fail to type. Typing it + again costs as much as the type of the scrutinee, for + every case. *) + let has_gadt_constructor = + Hashtbl.fold + (fun _ cstr found -> found || cstr.cstr_generalized) + constrs false + in + if not has_gadt_constructor then r + else + match pred constrs labels pattern with + | None -> + Location.prerr_warning q.pat_loc Warnings.Unreachable_case; + Used + | _ -> r in match r with | Unused -> @@ -2492,10 +2623,11 @@ let check_unused pred casel = | Used -> () with Empty | Not_found | NoGuard -> assert false); - if c_guard <> None then do_rec pref rem else do_rec ([q] :: pref) rem + if c_guard <> None then do_rec rows rem + else do_rec (add_row qs rows) rem in - if unused_match then do_rec [] casel + if unused_match then do_rec ([], Head_map.empty, []) casel (*********************************) (* Exported irrefutability tests *) @@ -2514,7 +2646,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; diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli index d7ad362797..a8b272da62 100644 --- a/compiler/ml/parmatch.mli +++ b/compiler/ml/parmatch.mli @@ -57,6 +57,10 @@ val lubs : pattern list -> pattern list -> pattern list val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list +(* [get_mins le_pats], without comparing rows whose first patterns are + different constants or polymorphic variant tags. *) +val get_mins_pats : pattern list list -> pattern list list + (* Those two functions recombine one pattern and its arguments: For instance: (_,_)::p1::p2::rem -> (p1, p2)::rem diff --git a/tests/build_tests/super_errors/expected/warning_11_unused_constants.res.expected b/tests/build_tests/super_errors/expected/warning_11_unused_constants.res.expected new file mode 100644 index 0000000000..736989e9eb --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_11_unused_constants.res.expected @@ -0,0 +1,83 @@ + + Warning number 11 + /.../fixtures/warning_11_unused_constants.res:4:5 + + 2 ┆ switch x { + 3 ┆ | 5 .. 5 => 0 + 4 ┆ | 5 => 1 + 5 ┆ | 1 .. 3 => 2 + 6 ┆ | 2 => 3 + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unused_constants.res:6:5 + + 4 ┆ | 5 => 1 + 5 ┆ | 1 .. 3 => 2 + 6 ┆ | 2 => 3 + 7 ┆ | 4 | 7 => 4 + 8 ┆ | 7 => 5 + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unused_constants.res:8:5 + + 6 ┆ | 2 => 3 + 7 ┆ | 4 | 7 => 4 + 8 ┆ | 7 => 5 + 9 ┆ | _ => 6 + 10 ┆ } + + this match case is unused. + + + Warning number 12 + /.../fixtures/warning_11_unused_constants.res:15:11-13 + + 13 ┆ switch x { + 14 ┆ | "a" => 0 + 15 ┆ | "b" | "a" => 1 + 16 ┆ | "b" => 2 + 17 ┆ | _ => 3 + + this sub-pattern is unused. + + + Warning number 11 + /.../fixtures/warning_11_unused_constants.res:16:5-7 + + 14 ┆ | "a" => 0 + 15 ┆ | "b" | "a" => 1 + 16 ┆ | "b" => 2 + 17 ┆ | _ => 3 + 18 ┆ } + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unused_constants.res:25:5-9 + + 23 ┆ | #B(1) => 1 + 24 ┆ | #B(_) => 2 + 25 ┆ | #B(1) => 3 + 26 ┆ | #A | #C => 4 + 27 ┆ } + + this match case is unused. + + + Warning number 12 + /.../fixtures/warning_11_unused_constants.res:26:5-6 + + 24 ┆ | #B(_) => 2 + 25 ┆ | #B(1) => 3 + 26 ┆ | #A | #C => 4 + 27 ┆ } + 28 ┆ + + this sub-pattern is unused. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning_11_unused_constants.res b/tests/build_tests/super_errors/fixtures/warning_11_unused_constants.res new file mode 100644 index 0000000000..5f801d35cb --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_11_unused_constants.res @@ -0,0 +1,27 @@ +let int = x => + switch x { + | 5 .. 5 => 0 + | 5 => 1 + | 1 .. 3 => 2 + | 2 => 3 + | 4 | 7 => 4 + | 7 => 5 + | _ => 6 + } + +let string = x => + switch x { + | "a" => 0 + | "b" | "a" => 1 + | "b" => 2 + | _ => 3 + } + +let variant = (x: [#A | #B(int) | #C]) => + switch x { + | #A => 0 + | #B(1) => 1 + | #B(_) => 2 + | #B(1) => 3 + | #A | #C => 4 + } From 063dd71e694c631096f058ebfdd3688a48ab742d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 7 Nov 2026 19:07:44 +0000 Subject: [PATCH 2/2] Skip the row index for matches with one case The benchmarks showed small matches, such as function parameters and let patterns, allocating up to 0.6% more for the index. get_mins_pats now returns fewer than two rows as they are, and the unused-case check doesn't index the last case, so such matches allocate less than before. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gK1dcjbe97yY1wRMgs Signed-off-by: Christoph Knittel --- compiler/ml/parmatch.ml | 67 +++++++++++++++++++++-------------------- 1 file changed, 35 insertions(+), 32 deletions(-) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 5aa9221129..77829a8e41 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -1830,38 +1830,41 @@ let row_head_key = function rows whose first pattern has the same key or none: comparing all pairs is quadratic for a switch on many constants or tags. *) let get_mins_pats pss = - (* The rows that no later row includes, in order. *) - let select pss = - let rec go keyed unkeyed kept = function - | [] -> kept - | ps :: rest -> - let includes ps0 = le_pats ps0 ps in - let key = row_head_key ps in - let included = - List.exists includes unkeyed - || - match key with - | Some key -> ( - match Head_map.find_opt key keyed with - | Some rows -> List.exists includes rows - | None -> false) - | None -> - Head_map.exists (fun _ rows -> List.exists includes rows) keyed - in - let keyed, unkeyed = - match key with - | Some key -> - ( Head_map.update key - (fun rows -> Some (ps :: Option.value rows ~default:[])) - keyed, - unkeyed ) - | None -> (keyed, ps :: unkeyed) - in - go keyed unkeyed (if included then kept else ps :: kept) rest + match pss with + | [] | [_] -> pss + | _ -> + (* The rows that no later row includes, in order. *) + let select pss = + let rec go keyed unkeyed kept = function + | [] -> kept + | ps :: rest -> + let includes ps0 = le_pats ps0 ps in + let key = row_head_key ps in + let included = + List.exists includes unkeyed + || + match key with + | Some key -> ( + match Head_map.find_opt key keyed with + | Some rows -> List.exists includes rows + | None -> false) + | None -> + Head_map.exists (fun _ rows -> List.exists includes rows) keyed + in + let keyed, unkeyed = + match key with + | Some key -> + ( Head_map.update key + (fun rows -> Some (ps :: Option.value rows ~default:[])) + keyed, + unkeyed ) + | None -> (keyed, ps :: unkeyed) + in + go keyed unkeyed (if included then kept else ps :: kept) rest + in + go Head_map.empty [] [] (List.rev pss) in - go Head_map.empty [] [] (List.rev pss) - in - List.rev (select (List.rev (select pss))) + List.rev (select (List.rev (select pss))) (* lub p q is a pattern that matches all values matched by p and q @@ -2623,7 +2626,7 @@ let check_unused pred casel = | Used -> () with Empty | Not_found | NoGuard -> assert false); - if c_guard <> None then do_rec rows rem + if c_guard <> None || rem = [] then do_rec rows rem else do_rec (add_row qs rows) rem in