From 181830354f2b11f464913b6967b0d0711b361067 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 11 Oct 2026 13:32:48 +0000 Subject: [PATCH 1/2] Check record labels once per record type Record expressions and patterns without a known type checked every field against all labels of each candidate record type, which is quadratic in the number of fields. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Christoph Knittel --- compiler/ml/typecore.ml | 49 ++++++++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 15 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 38ccbd57b8..185ce00764 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -995,36 +995,55 @@ module Label = Name_choice (struct let unbound_name_error = Typetexp.unbound_label_error end) -let disambiguate_label_by_ids closed ids labels = - let check_ids (lbl, _) = +(* [ids] are the fields of one record expression or pattern. Whether a + candidate label fits them only depends on the label's record type, so the + checks are done once per type ([lbl_all] is shared by its labels) rather + than for every field, which would be quadratic in the number of fields. *) +let disambiguate_label_by_ids closed ids = + let num_ids = List.length ids in + let check_ids lbl_all = (* check that all ids are present *) let lbls = Hashtbl.create 8 in - Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; + Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl_all; List.for_all (Hashtbl.mem lbls) ids in - let mandatory_labels_are_present num_ids lbl = + let mandatory_labels_are_present lbl_all = (* check that all mandatory labels are present *) - let has_optional_labels = Array.exists label_is_optional lbl.lbl_all in + let has_optional_labels = Array.exists label_is_optional lbl_all in if has_optional_labels then ( let mandatory_lbls = ref 0 in - lbl.lbl_all + lbl_all |> Array.iter (fun l -> if not (label_is_optional l) then incr mandatory_lbls); num_ids >= !mandatory_lbls) - else num_ids = Array.length lbl.lbl_all + else num_ids = Array.length lbl_all in - let check_closed (lbl, _) = - (not closed) || mandatory_labels_are_present (List.length ids) lbl + let checked = ref [] in + let check lbl_all = + match List.assq lbl_all !checked with + | result -> result + | exception Not_found -> + let result = + (check_ids lbl_all, (not closed) || mandatory_labels_are_present lbl_all) + in + checked := (lbl_all, result) :: !checked; + result in - let labels' = Ext_list.filter labels check_ids in - if labels' = [] then (false, labels) - else - let labels'' = Ext_list.filter labels' check_closed in - if labels'' = [] then (false, labels') else (true, labels'') + fun labels -> + let labels' = + Ext_list.filter labels (fun (lbl, _) -> fst (check lbl.lbl_all)) + in + if labels' = [] then (false, labels) + else + let labels'' = + Ext_list.filter labels' (fun (lbl, _) -> snd (check lbl.lbl_all)) + in + if labels'' = [] then (false, labels') else (true, labels'') (* Only issue warnings once per record constructor/pattern *) let disambiguate_record_elem_list loc closed env opath record_elem_list = let ids = List.map (fun {lid} -> Longident.last lid.txt) record_elem_list in + let disambiguate_by_ids = disambiguate_label_by_ids closed ids in let w_amb = ref [] in let warn loc msg = let open Warnings in @@ -1048,7 +1067,7 @@ let disambiguate_record_elem_list loc closed env opath record_elem_list = let ok, labels = match opath with | Some _ -> (true, scope) (* disambiguate only checks scope *) - | _ -> disambiguate_label_by_ids closed ids scope + | _ -> disambiguate_by_ids scope in if ok then Label.disambiguate lid env opath labels ~warn ~scope else fst (List.hd labels) From 3296593e9055f2fb67047e7e2965868ced5d3fd4 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 11 Oct 2026 19:30:31 +0000 Subject: [PATCH 2/2] Add CHANGELOG entry Co-Authored-By: Claude Opus 5.5 Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 94a7708ed9..cc9ffbfe61 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -59,6 +59,7 @@ #### :nail_care: Polish +- Speed up type checking of record expressions and patterns with many fields whose type is not known from context. https://github.com/rescript-lang/rescript/pull/8799 - Print list literals with one list cell per line, so their output no longer grows quadratically with their length. https://github.com/rescript-lang/rescript/pull/8794 - Compile dict spreads to object spread syntax instead of `Object.assign`. https://github.com/rescript-lang/rescript/pull/8747 - Make compilation slightly faster and stop rewatch from copying files twice for modules with an interface. https://github.com/rescript-lang/rescript/pull/8769