diff --git a/changes/pattern-variable-names.polish.md b/changes/pattern-variable-names.polish.md new file mode 100644 index 0000000000..54eb2d860b --- /dev/null +++ b/changes/pattern-variable-names.polish.md @@ -0,0 +1 @@ +- Speed up type checking of patterns that bind many variables, such as large `let rec` groups. diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 2ae56d4446..6f2221760a 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -148,6 +148,17 @@ let rp node = type recarg = Allowed | Required | Rejected +(* The variables bound so far by the pattern being typed, most recent first, + with their names: looking each new variable up in the list would make + patterns that bind many variables, like a large [let rec], quadratic. + Both are saved and restored together. *) +type pattern_variables = { + vars: (Ident.t * type_expr * string loc * Location.t * bool) list; + names: Set_string.t; +} + +let no_pattern_variables = {vars = []; names = Set_string.empty} + (* Typing a request mutates these stacks while traversing expressions and patterns. A failed request must not leave them in another request. *) type request_state = { @@ -156,8 +167,7 @@ type request_state = { break and continue must not leave. *) in_finally: bool ref; newtype_level: int option ref; - pattern_variables: - (Ident.t * type_expr * string loc * Location.t * bool) list ref; + pattern_variables: pattern_variables ref; pattern_force: (unit -> unit) list ref; allow_modules: bool ref; module_variables: (string loc * Location.t) list ref; @@ -168,7 +178,7 @@ let fresh_state () = loop_depth = ref 0; in_finally = ref false; newtype_level = ref None; - pattern_variables = ref []; + pattern_variables = ref no_pattern_variables; pattern_force = ref []; allow_modules = ref false; module_variables = ref []; @@ -540,20 +550,21 @@ let has_variants p = (* pattern environment *) let reset_pattern allow = - pattern_variables_ref () := []; + pattern_variables_ref () := no_pattern_variables; pattern_force_ref () := []; allow_modules_ref () := allow; module_variables_ref () := [] let enter_variable ?(is_module = false) ?(is_as_variable = false) loc name ty = - if - List.exists - (fun (id, _, _, _, _) -> Ident.name id = name.txt) - !(pattern_variables_ref ()) - then raise (Error (loc, Env.empty, Multiply_bound_variable name.txt)); + let {vars; names} = !(pattern_variables_ref ()) in + if Set_string.mem name.txt names then + raise (Error (loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create name.txt in pattern_variables_ref () := - (id, ty, name, loc, is_as_variable) :: !(pattern_variables_ref ()); + { + vars = (id, ty, name, loc, is_as_variable) :: vars; + names = Set_string.add name.txt names; + }; if is_module then ( (* Note: unpack patterns enter a variable of the same name *) if not !(allow_modules_ref ()) then @@ -1831,7 +1842,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp | Some p, None | None, Some p -> p (* no variables in this case *) | Some p1, Some p2 -> let alpha_env = - enter_orpat_variables loc !env p1_variables p2_variables + enter_orpat_variables loc !env p1_variables.vars p2_variables.vars in pattern_variables_ref () := p1_variables; module_variables_ref () := p1_module_variables; @@ -1959,7 +1970,8 @@ let check_unused ?(lev = get_current_level ()) env expected_ty cases = cases let add_pattern_variables ?check ?check_as env = - let pv = get_ref (pattern_variables_ref ()) in + let pv = !(pattern_variables_ref ()).vars in + pattern_variables_ref () := no_pattern_variables; ( List.fold_right (fun (id, ty, _name, loc, as_var) env -> let check = if as_var then check_as else check in diff --git a/tests/build_tests/super_errors/expected/multiply_bound_variable_alias.res.expected b/tests/build_tests/super_errors/expected/multiply_bound_variable_alias.res.expected new file mode 100644 index 0000000000..63f16ace44 --- /dev/null +++ b/tests/build_tests/super_errors/expected/multiply_bound_variable_alias.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/multiply_bound_variable_alias.res:3:5-16 + + 1 │ let f = x => + 2 │ switch x { + 3 │ | Some(a) as a => a + 4 │ | None => None + 5 │ } + + Variable a is bound several times in this pattern \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/multiply_bound_variable_let_rec.res.expected b/tests/build_tests/super_errors/expected/multiply_bound_variable_let_rec.res.expected new file mode 100644 index 0000000000..f07ae109ec --- /dev/null +++ b/tests/build_tests/super_errors/expected/multiply_bound_variable_let_rec.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/multiply_bound_variable_let_rec.res:3:5 + + 1 │ let rec f = () => g() + 2 │ and g = () => 1 + 3 │ and f = () => 2 + 4 │ + + Variable f is bound several times in this pattern \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/multiply_bound_variable_or_pattern.res.expected b/tests/build_tests/super_errors/expected/multiply_bound_variable_or_pattern.res.expected new file mode 100644 index 0000000000..122777c538 --- /dev/null +++ b/tests/build_tests/super_errors/expected/multiply_bound_variable_or_pattern.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/multiply_bound_variable_or_pattern.res:4:20 + + 2 ┆ switch x { + 3 ┆ | (Some(a), None) | (None, Some(a)) => a + 4 ┆ | (Some(a), Some(a)) => a + 5 ┆ | (None, None) => 0 + 6 ┆ } + + Variable a is bound several times in this pattern \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/multiply_bound_variable_alias.res b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_alias.res new file mode 100644 index 0000000000..725ef2a163 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_alias.res @@ -0,0 +1,5 @@ +let f = x => + switch x { + | Some(a) as a => a + | None => None + } diff --git a/tests/build_tests/super_errors/fixtures/multiply_bound_variable_let_rec.res b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_let_rec.res new file mode 100644 index 0000000000..eda28244db --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_let_rec.res @@ -0,0 +1,3 @@ +let rec f = () => g() +and g = () => 1 +and f = () => 2 diff --git a/tests/build_tests/super_errors/fixtures/multiply_bound_variable_or_pattern.res b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_or_pattern.res new file mode 100644 index 0000000000..69ad7f40b8 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/multiply_bound_variable_or_pattern.res @@ -0,0 +1,6 @@ +let f = (x: (option, option)) => + switch x { + | (Some(a), None) | (None, Some(a)) => a + | (Some(a), Some(a)) => a + | (None, None) => 0 + }