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