diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index 2a01bf8d0bb..72319b55843 100644 --- a/file_formats/cmt_format.ml +++ b/file_formats/cmt_format.ml @@ -238,15 +238,17 @@ let iter_on_occurrences modifs | Texp_extension_constructor (lid, path) -> f ~namespace:Extension_constructor exp_env path lid - | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ - | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_unboxed_tuple _ - | Texp_variant _ | Texp_array _ + | Texp_constant _ | Texp_let _ | Texp_letmutable _ | Texp_function _ + | Texp_apply _ | Texp_match _ | Texp_try _ | Texp_tuple _ + | Texp_unboxed_tuple _ | Texp_variant _ | Texp_array _ | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ | Texp_send _ | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_probe _ | Texp_probe_is_enabled _ | Texp_exclave _ + (* CR-someday let_mutable: maybe iterate on mutvar? *) + | Texp_mutvar _ | Texp_setmutvar _ | Texp_open _ | Texp_src_pos | Texp_overwrite _ | Texp_hole _ -> ()); default_iterator.expr sub e); diff --git a/jane/doc/extensions/_08-miscellaneous-extensions/let-mutable.md b/jane/doc/extensions/_08-miscellaneous-extensions/let-mutable.md new file mode 100644 index 00000000000..496f9541e74 --- /dev/null +++ b/jane/doc/extensions/_08-miscellaneous-extensions/let-mutable.md @@ -0,0 +1,35 @@ +# The `let mutable` extension + +The `let mutable` extension provides a new type of `let` statement which +declares a stack-local variable. It can be thought of as an unboxed `ref`. + +```ocaml +let triangle n = + let mutable total = 0 in + for i = 1 to n do + total <- total + i + done; + total +``` + +Mutable variables must not escape their scope. For example, you can't +return a closure that closes over a mutable variable. At the moment, the mode +checker is, sadly, not sophisticated enough to allow some constructions which +are obviously safe. For example, the following code is safe, but rejected by the +mode checker. + +```ocaml +let sum xs = + let mutable total = 0 in + List.iter xs ~f:(fun x -> total <- total + x); + total +``` + + +## Restrictions + +Mutable `let` declarations may not be recursive, and they may not be used at the +structure level or in class definitions. The pattern of a mutable `let` +statement must be a single variable, possibly with a type annotation, e.g. `let +mutable x, y = ..` and `let mutable add x y = ..` are not allowed. Mutable `let` +statements must also not use `and`s. diff --git a/lambda/matching.ml b/lambda/matching.ml index 5887c20c12f..c479d3d9da7 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -4270,7 +4270,7 @@ let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam = in List.fold_left push_sublet exit rev_sublets -let for_let ~scopes ~arg_sort ~return_layout loc param pat body = +let for_let ~scopes ~arg_sort ~return_layout loc param mutable_flag pat body = match pat.pat_desc with | Tpat_any -> (* This eliminates a useless variable (and stack slot in bytecode) @@ -4286,7 +4286,10 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body = non-polymorphic Ppat_constraint case in type_pat_aux. *) let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in - Llet (Strict, k, id, duid, param, body) + begin match mutable_flag with + | Asttypes.Mutable -> Lmutlet (k, id, duid, param, body) + | Asttypes.Immutable -> Llet (Strict, k, id, duid, param, body) + end | _ -> let opt = ref false in let nraise = next_raise_count () in @@ -4510,7 +4513,7 @@ let for_optional_arg_default Loc_unknown)) in for_let ~scopes ~arg_sort:default_arg_sort ~return_layout - loc supplied_or_default pat body + loc supplied_or_default Immutable pat body (* Error report *) (* CR layouts v5: This file didn't use to have the report_error infrastructure - diff --git a/lambda/matching.mli b/lambda/matching.mli index c1694124f5f..d7e9f31eaaf 100644 --- a/lambda/matching.mli +++ b/lambda/matching.mli @@ -32,7 +32,7 @@ val for_trywith: lambda val for_let: scopes:scopes -> arg_sort:Jkind.Sort.Const.t -> return_layout:layout -> - Location.t -> lambda -> pattern -> lambda -> + Location.t -> lambda -> Asttypes.mutable_flag -> pattern -> lambda -> lambda val for_multiple_match: scopes:scopes -> return_layout:layout -> Location.t -> diff --git a/lambda/transl_array_comprehension.ml b/lambda/transl_array_comprehension.ml index bbd1e8faf2b..c7c42635d15 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -515,7 +515,7 @@ let iterator ~transl_exp ~scopes ~loc : iter_arr_mut ), [iter_arr.var; Lvar iter_ix], loc )) - pattern body + Immutable pattern body } in mk_iterator, Array { iter_arr; iter_len } diff --git a/lambda/transl_list_comprehension.ml b/lambda/transl_list_comprehension.ml index 288239ac766..f28585d36f4 100644 --- a/lambda/transl_list_comprehension.ml +++ b/lambda/transl_list_comprehension.ml @@ -206,7 +206,8 @@ let iterator ~transl_exp ~scopes = function add_bindings = (* CR layouts: to change when we allow non-values in sequences *) Matching.for_let ~scopes ~arg_sort:Jkind.Sort.Const.for_list_element - ~return_layout:layout_any_value pattern.pat_loc (Lvar element) pattern + ~return_layout:layout_any_value pattern.pat_loc (Lvar element) + Immutable pattern } (** Translates a list comprehension binding diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 1ff02844f4f..ef026a339a6 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -392,6 +392,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let return_layout = layout_exp sort body in transl_let ~scopes ~return_layout rec_flag pat_expr_list (event_before ~scopes body (transl_exp ~scopes sort body)) + | Texp_letmutable(pat_expr, body) -> + let return_layout = layout_exp sort body in + transl_letmutable ~scopes ~return_layout pat_expr + (event_before ~scopes body (transl_exp ~scopes sort body)) | Texp_function { params; body; ret_sort; ret_mode; alloc_mode; zero_alloc } -> let ret_sort = Jkind.Sort.default_for_transl_and_get ret_sort in @@ -950,11 +954,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let self = transl_value_path loc e.exp_env path_self in let var = transl_value_path loc e.exp_env path in Lprim(Pfield_computed Reads_vary, [self; var], loc) + | Texp_mutvar id -> Lmutvar id.txt | Texp_setinstvar(path_self, path, _, expr) -> let loc = of_location ~scopes e.exp_loc in let self = transl_value_path loc e.exp_env path_self in let var = transl_value_path loc e.exp_env path in transl_setinstvar ~scopes loc self var expr + | Texp_setmutvar(id, expr_sort, expr) -> + Lassign(id.txt, transl_exp ~scopes + (Jkind.Sort.default_for_transl_and_get expr_sort) expr) | Texp_override(path_self, modifs) -> let loc = of_location ~scopes e.exp_loc in let self = transl_value_path loc e.exp_env path_self in @@ -1877,7 +1885,7 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) let mk_body = transl rem in fun body -> Matching.for_let ~scopes ~arg_sort:sort ~return_layout pat.pat_loc - lam pat (mk_body body) + lam Immutable pat (mk_body body) in transl pat_expr_list | Recursive -> @@ -1901,6 +1909,15 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) let lam_bds = List.map2 transl_case pat_expr_list idlist in fun body -> Value_rec_compiler.compile_letrec lam_bds body +and transl_letmutable ~scopes ~return_layout + {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc; vb_sort} body = + let arg_sort = Jkind_types.Sort.default_to_value_and_get vb_sort in + let lam = + transl_bound_exp ~scopes ~in_structure:false pat arg_sort expr vb_loc attr + in + Matching.for_let ~scopes ~return_layout ~arg_sort pat.pat_loc lam Mutable + pat body + and transl_setinstvar ~scopes loc self var expr = let ptr_or_imm, _ = maybe_pointer expr in Lprim(Psetfield_computed (ptr_or_imm, Assignment modify_heap), diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 7467044335e..3eae30e306d 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -212,7 +212,7 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let let_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_let (a, b, c, d)) let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) @@ -236,7 +236,7 @@ module Exp = struct let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setvar (a, b)) let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 146b9297560..753cca26902 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -150,8 +150,8 @@ module Exp: val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression + val let_: ?loc:loc -> ?attrs:attrs -> mutable_flag -> rec_flag -> + value_binding list -> expression -> expression val function_ : ?loc:loc -> ?attrs:attrs -> function_param list -> function_constraint -> function_body -> expression diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index bd82cbe7c69..ccbfa4d4584 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -27,6 +27,8 @@ let short_closed_tuple_pat loc = err loc "Closed tuple patterns must have at least 2 components." let no_args loc = err loc "Function application with no argument." let empty_let loc = err loc "Let with no bindings." +let mutable_rec_let loc = err loc "Mutable let binding cannot be recursive." +let multiple_mutable_let loc = err loc "Mutable let must have only one binding." let empty_type loc = err loc "Type declarations cannot be empty." let complex_id loc = err loc "Functor application not allowed here." let module_type_substitution_missing_rhs loc = @@ -118,7 +120,11 @@ let iterator = | Pexp_tuple ([] | [_]) -> invalid_tuple loc | Pexp_record ([], _) -> empty_record loc | Pexp_apply (_, []) -> no_args loc - | Pexp_let (_, [], _) -> empty_let loc + | Pexp_let (_, _, [], _) -> empty_let loc + | Pexp_let (Mutable, Recursive, _, _) -> mutable_rec_let loc + | Pexp_let (Mutable, _, l, _) when List.length l > 1 -> + multiple_mutable_let loc + (* CR jrayman: test previous two invariants *) | Pexp_ident id | Pexp_construct (id, _) | Pexp_field (_, id) diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index f38dae2f091..5d802a21fda 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -462,7 +462,7 @@ module E = struct match desc with | Pexp_ident x -> iter_loc sub x | Pexp_constant _ -> () - | Pexp_let (_r, vbs, e) -> + | Pexp_let (_m, _r, vbs, e) -> List.iter (sub.value_binding sub) vbs; sub.expr sub e | Pexp_function (params, constraint_, body) -> @@ -510,7 +510,7 @@ module E = struct sub.modes sub m | Pexp_send (e, _s) -> sub.expr sub e | Pexp_new lid -> iter_loc sub lid - | Pexp_setinstvar (s, e) -> + | Pexp_setvar (s, e) -> iter_loc sub s; sub.expr sub e | Pexp_override sel -> List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 1d83c76c2b5..84fe9a86c81 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -531,8 +531,8 @@ module E = struct match desc with | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + | Pexp_let (m, r, vbs, e) -> + let_ ~loc ~attrs m r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) | Pexp_function (ps, c, b) -> function_ ~loc ~attrs @@ -585,7 +585,7 @@ module E = struct | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> + | Pexp_setvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_override sel -> override ~loc ~attrs diff --git a/parsing/depend.ml b/parsing/depend.ml index 4868bd9dfc7..10e7290f5ba 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -240,7 +240,7 @@ let rec add_expr bv exp = match exp.pexp_desc with Pexp_ident l -> add bv l | Pexp_constant _ -> () - | Pexp_let(rf, pel, e) -> + | Pexp_let(_mf, rf, pel, e) -> let bv = add_bindings rf bv pel in add_expr bv e | Pexp_function (params, constraint_, body) -> let bv = List.fold_left add_function_param bv params in @@ -276,7 +276,7 @@ let rec add_expr bv exp = Option.iter (add_type bv) ty2 | Pexp_send(e, _m) -> add_expr bv e | Pexp_new li -> add bv li - | Pexp_setinstvar(_v, e) -> add_expr bv e + | Pexp_setvar(_v, e) -> add_expr bv e | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel | Pexp_letmodule(id, m, e) -> let b = add_module_binding bv m in diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml index fc26c1bfb29..1cf281dbab0 100644 --- a/parsing/language_extension.ml +++ b/parsing/language_extension.ml @@ -74,6 +74,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Small_numbers -> (module Maturity) | Instances -> (module Unit) | Separability -> (module Unit) + | Let_mutable -> (module Unit) (* We'll do this in a more principled way later. *) (* CR layouts: Note that layouts is only "mostly" erasable, because of annoying @@ -87,7 +88,7 @@ let is_erasable : type a. a t -> bool = function | Mode | Unique | Overwriting | Layouts -> true | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances - | Separability -> + | Separability | Let_mutable -> false let maturity_of_unique_for_drf = Stable @@ -112,6 +113,7 @@ module Exist_pair = struct | Pair (Small_numbers, m) -> m | Pair (Instances, ()) -> Stable | Pair (Separability, ()) -> Stable + | Pair (Let_mutable, ()) -> Stable let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext @@ -125,7 +127,7 @@ module Exist_pair = struct | Pair ( (( Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening | Labeled_tuples - | Instances | Overwriting | Separability ) as ext), + | Instances | Overwriting | Separability | Let_mutable ) as ext), _ ) -> to_string ext @@ -157,6 +159,7 @@ module Exist_pair = struct | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | "instances" -> Some (Pair (Instances, ())) | "separability" -> Some (Pair (Separability, ())) + | "let_mutable" -> Some (Pair (Let_mutable, ())) | _ -> None end @@ -178,7 +181,8 @@ let all_extensions = Pack Labeled_tuples; Pack Small_numbers; Pack Instances; - Pack Separability ] + Pack Separability; + Pack Let_mutable ] (**********************************) (* string conversions *) @@ -218,10 +222,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = | Small_numbers, Small_numbers -> Some Refl | Instances, Instances -> Some Refl | Separability, Separability -> Some Refl + | Let_mutable, Let_mutable -> Some Refl | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances - | Separability ), + | Separability | Let_mutable ), _ ) -> None diff --git a/parsing/language_extension.mli b/parsing/language_extension.mli index 005829fb821..869fbf44e04 100644 --- a/parsing/language_extension.mli +++ b/parsing/language_extension.mli @@ -32,6 +32,7 @@ type 'a t = 'a Language_extension_kernel.t = | Small_numbers : maturity t | Instances : unit t | Separability : unit t + | Let_mutable : unit t (** Require that an extension is enabled for at least the provided level, or else throw an exception at the provided location saying otherwise. *) diff --git a/parsing/parse.ml b/parsing/parse.ml index 1b3f6da349a..aeabdd1c6df 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -178,6 +178,20 @@ let prepare_error err = | Malformed_instance_identifier loc -> Location.errorf ~loc "Syntax error: Unexpected in module instance" + | Let_mutable_not_allowed_at_structure_level loc -> + Location.errorf ~loc + "Syntax error: Mutable let bindings are not allowed \ + at the structure level." + | Let_mutable_not_allowed_in_class_definition loc -> + Location.errorf ~loc + "Syntax error: Mutable let bindings are not allowed \ + inside class definitions." + | Let_mutable_not_allowed_with_function_bindings loc -> + Location.errorf ~loc + "Syntax error: Mutable let is not allowed with function bindings.\n\ + @{Hint@}: If you really want a mutable function variable, \ + use the de-sugared syntax:\n %a" + Style.inline_code "let mutable f = fun x -> .." let () = Location.register_error_of_exn diff --git a/parsing/parser.mly b/parsing/parser.mly index 42c8571f992..6b3e0ea35f2 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -670,9 +670,10 @@ let addlb lbs lb = if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error (); { lbs with lbs_bindings = lb :: lbs.lbs_bindings } -let mklbs ext rf lb = +let mklbs ext mf rf lb = let lbs = { lbs_bindings = []; + lbs_mutable = mf; lbs_rec = rf; lbs_extension = ext; } in @@ -689,10 +690,27 @@ let val_of_let_bindings ~loc lbs = ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in - let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in - match lbs.lbs_extension with - | None -> str - | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), [])) + match lbs.lbs_mutable with + | Mutable -> + raise (Syntaxerr.Error + (Syntaxerr.Let_mutable_not_allowed_at_structure_level (make_loc loc))) + | Immutable -> + let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in + match lbs.lbs_extension with + | None -> str + | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), [])) + + +(* Find the location of the first binding in [bindings] that contains a ghost + * function expression. This is used to disallow [let mutable f x y = ..]. *) +let ghost_fun_binding_loc bindings = + List.find_opt (fun binding -> + match binding.lb_expression.pexp_loc.loc_ghost, + binding.lb_expression.pexp_desc + with + | true, Pexp_function _ -> true | _ -> false) + bindings + |> Option.map (fun binding -> binding.lb_loc) let expr_of_let_bindings ~loc lbs body = let bindings = @@ -703,7 +721,15 @@ let expr_of_let_bindings ~loc lbs body = ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in - mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) + (* Disallow [let mutable f x y = ..] but still allow + * [let mutable f = fun x y -> ..]. *) + match lbs.lbs_mutable, ghost_fun_binding_loc lbs.lbs_bindings with + | Mutable, Some loc -> + raise (Syntaxerr.Error + (Syntaxerr.Let_mutable_not_allowed_with_function_bindings loc)) + | _ -> + mkexp_attrs ~loc + (Pexp_let(lbs.lbs_mutable, lbs.lbs_rec, List.rev bindings, body)) (lbs.lbs_extension, []) let class_of_let_bindings ~loc lbs body = @@ -715,9 +741,14 @@ let class_of_let_bindings ~loc lbs body = ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in - (* Our use of let_bindings(no_ext) guarantees the following: *) - assert (lbs.lbs_extension = None); - mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) + match lbs.lbs_mutable with + | Mutable -> + raise (Syntaxerr.Error + (Syntaxerr.Let_mutable_not_allowed_in_class_definition (make_loc loc))) + | Immutable -> + (* Our use of let_bindings(no_ext) guarantees the following: *) + assert (lbs.lbs_extension = None); + mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) (* If all the parameters are [Pparam_newtype x], then return [Some xs] where [xs] is the corresponding list of values [x]. This function is optimized for @@ -2805,7 +2836,7 @@ fun_expr: { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[None, $1;None, $3])) } | mkrhs(label) LESSMINUS expr - { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) } + { mkexp ~loc:$sloc (Pexp_setvar($1, $3)) } | simple_expr DOT mkrhs(label_longident) LESSMINUS expr { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) } | indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v}) @@ -3230,12 +3261,13 @@ let_bindings(EXT): LET ext = EXT attrs1 = attributes + mutable_flag = mutable_flag rec_flag = rec_flag body = let_binding_body attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in - mklbs ext rec_flag (mklb ~loc:$sloc true body attrs) + mklbs ext mutable_flag rec_flag (mklb ~loc:$sloc true body attrs) } ; and_let_binding: diff --git a/parsing/parser_types.ml b/parsing/parser_types.ml index 384972e15cb..60c25dfc032 100644 --- a/parsing/parser_types.ml +++ b/parsing/parser_types.ml @@ -15,5 +15,6 @@ type let_binding = type let_bindings = { lbs_bindings: let_binding list; + lbs_mutable: mutable_flag; lbs_rec: rec_flag; lbs_extension: string Asttypes.loc option } diff --git a/parsing/parser_types.mli b/parsing/parser_types.mli index a9a4662a155..1d60ccabdc6 100644 --- a/parsing/parser_types.mli +++ b/parsing/parser_types.mli @@ -20,5 +20,6 @@ type let_binding = type let_bindings = { lbs_bindings: let_binding list; + lbs_mutable: mutable_flag; lbs_rec: rec_flag; lbs_extension: string Asttypes.loc option } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index c2a77555dee..dd7698a69af 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -365,13 +365,23 @@ and expression_desc = | Pexp_constant of constant (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) - | Pexp_let of rec_flag * value_binding list * expression - (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + | Pexp_let of mutable_flag * rec_flag * value_binding list * expression + (** [Pexp_let(mut, rec, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - [let P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]} + and [mut] = {{!Asttypes.mutable_flag.Immutable}[Immutable]}. - [let rec P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]} + and [mut] = {{!Asttypes.mutable_flag.Immutable}[Immutable]}. + - [let mutable P1 = E1 in E] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]} + and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + Invariant: If [mut = Mutable] then [n = 1] and [rec = Nonrecursive] *) + + (* CR jrayman: The parser forbids the sugared function syntax with + * [mut = Mutable] (e.g. [let mutable f x y = ..]) by checking if the RHS + * of the binding is a ghost function expression. Does this method prevent + * PPXs from generating mutable function bindings? *) | Pexp_function of function_param list * function_constraint * function_body (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct @@ -469,7 +479,11 @@ and expression_desc = *) | Pexp_send of expression * label loc (** [E # m] *) | Pexp_new of Longident.t loc (** [new M.c] *) - | Pexp_setinstvar of label loc * expression (** [x <- 2] *) + | Pexp_setvar of label loc * expression + (** [x <- 2] + + Represents both setting an instance variable + and setting a mutable variable. *) | Pexp_override of (label loc * expression) list (** [{< x1 = E1; ...; xn = En >}] *) | Pexp_letmodule of string option loc * module_expr * expression diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 55941acd81b..c1732d1316e 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -995,12 +995,13 @@ and expression ctxt f x = pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" (* "try@;@[<2>%a@]@\nwith@\n%a"*) (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> + | Pexp_let (mf, rf, l, e) -> (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" (*no indentation here, a new line*) *) (* rec_flag rf *) + (* mutable_flag mf *) pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) + (bindings reset_ctxt) (mf,rf,l) (expression ctxt) e | Pexp_apply ({ pexp_desc = Pexp_extension({txt = "extension.exclave"}, PStr []) }, @@ -1080,7 +1081,7 @@ and expression ctxt f x = (list (expression (under_semi ctxt)) ~sep:";@;") lst | Pexp_new (li) -> pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> + | Pexp_setvar (s, e) -> pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e | Pexp_override l -> (* FIXME *) let string_x_expression f (s, e) = @@ -1412,7 +1413,7 @@ and class_expr ctxt f x = (class_expr ctxt) e | Pcl_let (rf, l, ce) -> pp f "%a@ in@ %a" - (bindings ctxt) (rf,l) + (bindings ctxt) (Immutable,rf,l) (class_expr ctxt) ce | Pcl_apply (ce, l) -> pp f "((%a)@ %a)" (* Cf: #7200 *) @@ -1818,8 +1819,8 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; pvb_modes = mode end (* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = +and bindings ctxt f (mf,rf,l) = + let binding kwd mf rf f x = (* The other modes are printed inside [binding] *) let legacy, x = if print_modes_in_old_syntax x.pvb_modes then @@ -1827,18 +1828,18 @@ and bindings ctxt f (rf,l) = else [], x in - pp f "@[<2>%s %a%a%a@]%a" kwd rec_flag rf + pp f "@[<2>%s %a%a%a%a@]%a" kwd mutable_flag mf rec_flag rf optional_legacy_modes legacy (binding ctxt) x (item_attributes ctxt) x.pvb_attributes in match l with | [] -> () - | [x] -> binding "let" rf f x + | [x] -> binding "let" mf rf f x | x::xs -> pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs + (binding "let" mf rf) x + (list ~sep:"@," (binding "and" Immutable Nonrecursive)) xs and binding_op ctxt f x = match x.pbop_pat, x.pbop_exp with @@ -1860,7 +1861,7 @@ and structure_item ctxt f x = | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) | Pstr_value (rf, l) -> (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + pp f "@[<2>%a@]" (bindings ctxt) (Immutable,rf,l) | Pstr_typext te -> type_extension ctxt f te | Pstr_exception ed -> exception_declaration ctxt f ed | Pstr_module x -> diff --git a/parsing/printast.ml b/parsing/printast.ml index ce78866d0da..3af933cd04c 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -310,8 +310,8 @@ and expression i ppf x = match x.pexp_desc with | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; - | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + | Pexp_let (mf, rf, l, e) -> + line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; | Pexp_function (params, c, body) -> @@ -400,8 +400,8 @@ and expression i ppf x = line i ppf "Pexp_send \"%s\"\n" s.txt; expression i ppf e; | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; - | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + | Pexp_setvar (s, e) -> + line i ppf "Pexp_setvar %a\n" fmt_string_loc s; expression i ppf e; | Pexp_override (l) -> line i ppf "Pexp_override\n"; diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index c1dbac71d7b..9ff59817696 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -35,6 +35,9 @@ type error = | Removed_string_set of Location.t | Missing_unboxed_literal_suffix of Location.t | Malformed_instance_identifier of Location.t + | Let_mutable_not_allowed_at_structure_level of Location.t + | Let_mutable_not_allowed_in_class_definition of Location.t + | Let_mutable_not_allowed_with_function_bindings of Location.t exception Error of error exception Escape_error @@ -51,6 +54,9 @@ let location_of_error = function | Removed_string_set l -> l | Missing_unboxed_literal_suffix l -> l | Malformed_instance_identifier l -> l + | Let_mutable_not_allowed_at_structure_level l -> l + | Let_mutable_not_allowed_in_class_definition l -> l + | Let_mutable_not_allowed_with_function_bindings l -> l let ill_formed_ast loc s = diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 47f2910fd0e..ffae83098df 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -40,6 +40,9 @@ type error = | Removed_string_set of Location.t | Missing_unboxed_literal_suffix of Location.t | Malformed_instance_identifier of Location.t + | Let_mutable_not_allowed_at_structure_level of Location.t + | Let_mutable_not_allowed_in_class_definition of Location.t + | Let_mutable_not_allowed_with_function_bindings of Location.t exception Error of error exception Escape_error diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index ca665202272..d00cab6f149 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -334,8 +334,8 @@ and expression i ppf x = match x.pexp_desc with | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; - | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + | Pexp_let (mf, rf, l, e) -> + line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; | Pexp_function (params, c, body) -> @@ -424,8 +424,8 @@ and expression i ppf x = line i ppf "Pexp_send \"%s\"\n" s.txt; expression i ppf e; | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; - | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + | Pexp_setvar (s, e) -> + line i ppf "Pexp_setvar %a\n" fmt_string_loc s; expression i ppf e; | Pexp_override (l) -> line i ppf "Pexp_override\n"; diff --git a/testsuite/tests/ast-invariants/test.reference b/testsuite/tests/ast-invariants/test.reference index e69de29bb2d..85aa6f6cd8f 100644 --- a/testsuite/tests/ast-invariants/test.reference +++ b/testsuite/tests/ast-invariants/test.reference @@ -0,0 +1,9 @@ +File "/home/zqian/local/repos/let-mutable/_runtest/testsuite/tests/typing-local/let_mutable.ml", lines 200-206, characters 2-15: +200 | ..let mutable x = [] +201 | and z = 3 +202 | in +203 | x <- z :: x; +204 | match x with +205 | | [] -> 0 +206 | | z :: _ -> z +Error: broken invariant in parsetree: Mutable let must have only one binding. diff --git a/testsuite/tests/messages/spellcheck.ml b/testsuite/tests/messages/spellcheck.ml index c403d92fa15..062771fbbd6 100644 --- a/testsuite/tests/messages/spellcheck.ml +++ b/testsuite/tests/messages/spellcheck.ml @@ -124,7 +124,7 @@ let _ = Line 5, characters 22-33: 5 | method update n = foobaz <- n ^^^^^^^^^^^ -Error: The value "foobaz" is not an instance variable +Error: The value "foobaz" is not an instance variable or mutable variable Hint: Did you mean "foobar"? |}];; diff --git a/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference b/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference new file mode 100644 index 00000000000..4096b7014b6 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference @@ -0,0 +1,7 @@ + + +Line 6, characters 0-18: +6 | let mutable x = 10 + ^^^^^^^^^^^^^^^^^^ +Error: Syntax error: Mutable let bindings are not allowed at the structure level. + diff --git a/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml b/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml new file mode 100644 index 00000000000..18da66759af --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml @@ -0,0 +1,6 @@ +(* TEST + flags = "-extension let_mutable"; + toplevel; *) + +(* let mutable not allowed at structure level *) +let mutable x = 10 diff --git a/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference b/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference new file mode 100644 index 00000000000..2373afa053f --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference @@ -0,0 +1,11 @@ + + +Lines 7-12, characters 2-5: + 7 | ..let mutable x = 20 in + 8 | object + 9 | method read_incr = +10 | x <- x + 1; +11 | x +12 | end +Error: Syntax error: Mutable let bindings are not allowed inside class definitions. + diff --git a/testsuite/tests/parse-errors/let_mutable_in_class.ml b/testsuite/tests/parse-errors/let_mutable_in_class.ml new file mode 100644 index 00000000000..b8dc031bba3 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_class.ml @@ -0,0 +1,12 @@ +(* TEST + flags = "-extension let_mutable"; + toplevel; *) + +(* let mutable is not allowed in class definitions *) +class c = + let mutable x = 20 in + object + method read_incr = + x <- x + 1; + x + end diff --git a/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference b/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference new file mode 100644 index 00000000000..e3134e4eeea --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference @@ -0,0 +1,7 @@ + + +Line 7, characters 2-20: +7 | let mutable x = 20 + ^^^^^^^^^^^^^^^^^^ +Error: Syntax error: Mutable let bindings are not allowed at the structure level. + diff --git a/testsuite/tests/parse-errors/let_mutable_in_module.ml b/testsuite/tests/parse-errors/let_mutable_in_module.ml new file mode 100644 index 00000000000..f5f7886c604 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_module.ml @@ -0,0 +1,8 @@ +(* TEST + flags = "-extension let_mutable"; + toplevel; *) + +(* let mutable not allowed at structure level *) +module M = struct + let mutable x = 20 +end diff --git a/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference new file mode 100644 index 00000000000..c6009032946 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference @@ -0,0 +1,5 @@ +Line 5, characters 20-21: +5 | let _ = let mutable x = 20 in x;; + ^ +Error: The extension "let_mutable" is disabled and cannot be used + diff --git a/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml new file mode 100644 index 00000000000..633f45061a0 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml @@ -0,0 +1,5 @@ +(* TEST + flags = "-extension-universe upstream_compatible"; + toplevel; *) + +let _ = let mutable x = 20 in x;; diff --git a/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference new file mode 100644 index 00000000000..e8de087c2d6 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference @@ -0,0 +1,7 @@ +Line 6, characters 8-27: +6 | let _ = let mutable f x = x in f;; + ^^^^^^^^^^^^^^^^^^^ +Error: Syntax error: Mutable let is not allowed with function bindings. +Hint: If you really want a mutable function variable, use the de-sugared syntax: + "let mutable f = fun x -> .." + diff --git a/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml new file mode 100644 index 00000000000..fee091acd64 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml @@ -0,0 +1,6 @@ +(* TEST + flags = "-extension let_mutable"; + toplevel; *) + +(* let mutable not allowed with function bindings *) +let _ = let mutable f x = x in f;; diff --git a/testsuite/tests/parsetree/locations_test.compilers.reference b/testsuite/tests/parsetree/locations_test.compilers.reference index 48cbb759383..a3afe02b733 100644 --- a/testsuite/tests/parsetree/locations_test.compilers.reference +++ b/testsuite/tests/parsetree/locations_test.compilers.reference @@ -1341,7 +1341,7 @@ Ptop_def structure_item (//toplevel//[2,1+0]..[5,76+12]) Pstr_eval expression (//toplevel//[2,1+0]..[5,76+12]) - Pexp_let Nonrec + Pexp_let Immutable Nonrec [ pattern (//toplevel//[2,1+4]..[2,1+5]) @@ -1445,7 +1445,7 @@ Ptop_def None Pfunction_body expression (//toplevel//[4,76+2]..[5,98+12]) - Pexp_let Nonrec + Pexp_let Immutable Nonrec [ pattern (//toplevel//[4,76+6]..[4,76+7]) diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index b873c57c4e4..768cf69f7e2 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -1495,3 +1495,17 @@ let f g here = g ~(here : [%call_pos]) [%%expect{| val f : (here:[%call_pos] -> 'a) -> lexing_position -> 'a = |}] + +(***************) +(* let mutable *) + +let triangle_10 = let mutable x = 0 in + for i = 1 to 10 do + x <- x + i + done; + x +;; + +[%%expect{| +val triangle_10 : int = 55 +|}] diff --git a/testsuite/tests/parsing/extensions.compilers.reference b/testsuite/tests/parsing/extensions.compilers.reference index eebe76cecc5..a8c4e4cb753 100644 --- a/testsuite/tests/parsing/extensions.compilers.reference +++ b/testsuite/tests/parsing/extensions.compilers.reference @@ -5,7 +5,7 @@ structure_item (extensions.ml[9,153+7]..[9,153+21]) Pstr_eval expression (extensions.ml[9,153+7]..[9,153+21]) - Pexp_let Nonrec + Pexp_let Immutable Nonrec [ pattern (extensions.ml[9,153+11]..[9,153+12]) diff --git a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference index 271e61f971c..573544780ed 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference +++ b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference @@ -12,7 +12,7 @@ structure_item (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) Pstr_eval expression (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) - Pexp_let Nonrec + Pexp_let Immutable Nonrec [ attribute "foo" diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml new file mode 100644 index 00000000000..8429657de2b --- /dev/null +++ b/testsuite/tests/typing-layouts/let_mutable.ml @@ -0,0 +1,83 @@ +(* TEST + reference = "${test_source_directory}/let_mutable.reference"; + include stdlib_upstream_compatible; + flambda2; + { + flags = "-extension let_mutable"; + native; + }{ + flags = "-extension let_mutable"; + bytecode; + }{ + flags = "-extension layouts_alpha -extension let_mutable"; + native; + }{ + flags = "-extension layouts_alpha -extension let_mutable"; + bytecode; + }{ + flags = "-extension layouts_beta -extension let_mutable"; + native; + }{ + flags = "-extension layouts_beta -extension let_mutable"; + bytecode; + }*) + +open Stdlib_upstream_compatible + +let triangle_f64 n = + let mutable sum = #0.0 in + for i = 1 to n do + sum <- Float_u.add sum (Float_u.of_int i) + done; + sum + +let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float_u.to_float) + + +let triangle_f32 n = + let mutable sum = #0.0s in + for i = 1 to n do + sum <- Float32_u.add sum (Float32_u.of_int i) + done; + sum + +let () = Printf.printf "%.2f\n" (triangle_f32 10 |> Float32_u.to_float) + + +let triangle_i64 n = + let mutable sum = #0L in + for i = 1 to n do + sum <- Int64_u.add sum (Int64_u.of_int i) + done; + sum + +let () = Printf.printf "%d\n" (triangle_i64 10 |> Int64_u.to_int) + + +let triangle_i32 n = + let mutable sum = #0l in + for i = 1 to n do + sum <- Int32_u.add sum (Int32_u.of_int i) + done; + sum + +let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int) + + +(* CR jrayman: how do you create a vec128? *) + +let triangle_i64_i32_f64 n = + let mutable sum = #(#0L, #(#0l, #0.)) in + for i = 1 to n do + let #(a, #(b, c)) = sum in + sum <- #(Int64_u.add a (Int64_u.of_int i), + #(Int32_u.add b (Int32_u.of_int i), + Float_u.add c (Float_u.of_int i))) + done; + sum + +let () = + let #(a, #(b, c)) = triangle_i64_i32_f64 10 in + Printf.printf "%d %d %.2f\n" (Int64_u.to_int a) + (Int32_u.to_int b) + (Float_u.to_float c) diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference new file mode 100644 index 00000000000..017dceb4972 --- /dev/null +++ b/testsuite/tests/typing-layouts/let_mutable.reference @@ -0,0 +1,5 @@ +55.00 +55.00 +55 +55 +55 55 55.00 diff --git a/testsuite/tests/typing-local/alloc.heap.reference b/testsuite/tests/typing-local/alloc.heap.reference index 8a7449cbf7d..e4827df2031 100644 --- a/testsuite/tests/typing-local/alloc.heap.reference +++ b/testsuite/tests/typing-local/alloc.heap.reference @@ -36,3 +36,4 @@ optionaleta: Allocation object: Allocation object_direct: Allocation + let_mutable: Allocation diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index 87cedc009e7..30d59ee2568 100644 --- a/testsuite/tests/typing-local/alloc.ml +++ b/testsuite/tests/typing-local/alloc.ml @@ -1,4 +1,5 @@ (* TEST + flags = "-extension let_mutable"; { reference = "${test_source_directory}/alloc.heap.reference"; bytecode; @@ -470,6 +471,13 @@ let obj_direct () = end); () +let let_mutable_loop () = + let mutable x = [] in + for i = 0 to 10 do exclave_ + x <- stack_ (i :: x) + done; + ignore_local x + let run name f x = let prebefore = Gc.allocated_bytes () in let before = Gc.allocated_bytes () in @@ -525,7 +533,8 @@ let () = run "optionalarg" optionalarg (fun_with_optional_arg, 10); run "optionaleta" optionaleta (); run "object" obj (); - run "object_direct" obj_direct () + run "object_direct" obj_direct (); + run "let_mutable" let_mutable_loop () (* The following test commented out as it require more memory than the CI has *) diff --git a/testsuite/tests/typing-local/alloc.stack.reference b/testsuite/tests/typing-local/alloc.stack.reference index b635f9fe36f..998fd416a87 100644 --- a/testsuite/tests/typing-local/alloc.stack.reference +++ b/testsuite/tests/typing-local/alloc.stack.reference @@ -36,3 +36,4 @@ optionaleta: No Allocation object: Allocation object_direct: Allocation + let_mutable: No Allocation diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml new file mode 100644 index 00000000000..31c4e1d12e0 --- /dev/null +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -0,0 +1,403 @@ +(* TEST + flags = "-extension let_mutable"; + include stdlib_upstream_compatible; + expect; *) + +(* Test 1.1: basic usage in a for loop *) +let foo1 y = + let mutable x = y in + for i = 1 to 10 do + x <- x + i + done; + x + +let () = assert (Int.equal (foo1 0) 55) +let () = assert (Int.equal (foo1 42) 97) + +[%%expect{| +val foo1 : int -> int = +|}] + +(* Test 1.2: basic usage with a nested record *) +type t_1_2 = { str_1_2 : string ref } +let x_1_2 = + let mutable x = { str_1_2 = ref "Hi" } in + x <- { str_1_2 = ref "Bye" }; + x +[%%expect{| +type t_1_2 = { str_1_2 : string ref; } +val x_1_2 : t_1_2 = {str_1_2 = {contents = "Bye"}} +|}] + + +(* Test 2: Reject use of mutable in closure. *) +let foo2 y = + let mutable x = y in + let add_55 () = + for i = 1 to 10 do + x <- x + i + done; + x + in + add_55 + +[%%expect{| +Line 5, characters 6-16: +5 | x <- x + i + ^^^^^^^^^^ +Error: Mutable variable cannot be used inside closure. +|}] + +(* Test 3: Rejected for same reason as test 2, but this one is actually safe and + could be allowed with more sophisticated analysis in the future. *) +let foo3 y = + let mutable x = y in + let rec add_55 z = + match z with + | 0 -> x + | z -> x <- x + z; add_55 (z-1) + in + add_55 10 +[%%expect{| +Line 5, characters 11-12: +5 | | 0 -> x + ^ +Error: Mutable variable cannot be used inside closure. +|}] + +(* Test 4: Disallowed interactions with locals *) +let foo4_1 y = + let mutable x = [] in + for i = 1 to y do + x <- local_ (i :: x) + done; + match x with + | [] -> assert false + | (x :: xs) -> x + +[%%expect{| +Line 4, characters 9-24: +4 | x <- local_ (i :: x) + ^^^^^^^^^^^^^^^ +Error: This value escapes its region. +|}] + + +let foo4_2 y = (* Can't sneak local out of non-local for loop body region *) + let mutable x = [] in + let build_loop () = + for i = 1 to y do exclave_ + x <- local_ (i :: x) + done; + match x with + | [] -> assert false + | (x :: xs) -> x + in + build_loop () + +[%%expect{| +Line 5, characters 6-26: +5 | x <- local_ (i :: x) + ^^^^^^^^^^^^^^^^^^^^ +Error: Mutable variable cannot be used inside closure. +|}] + + +let foo4_3 y = (* Can't sneak local out of non-local while loop body region *) + let mutable x = y in + let i = ref 1 in + while !i <= 10 do + x <- (local_ (x + !i)); + i := !i + 1; + done; x + +[%%expect{| +Line 5, characters 9-26: +5 | x <- (local_ (x + !i)); + ^^^^^^^^^^^^^^^^^ +Error: This value escapes its region. +|}] + +let foo4_4 y = (* Can't sneak local out of non-local while cond region *) + let mutable x = y in + while x <- (local_ (x + 1)); x <= 100 do + x <- x + x + done; x + +[%%expect{| +Line 3, characters 13-29: +3 | while x <- (local_ (x + 1)); x <= 100 do + ^^^^^^^^^^^^^^^^ +Error: This value escapes its region. +|}] + +(* exclave_ closes one region, not two *) +let foo4_5 y = + let mutable x = [] in + for i = 1 to y do + for j = 1 to y do exclave_ + x <- local_ ((i*j) :: x) + done + done; + x +;; +[%%expect{| +Line 5, characters 11-30: +5 | x <- local_ ((i*j) :: x) + ^^^^^^^^^^^^^^^^^^^ +Error: This value escapes its region. +|}] + +let foo4_6 y = + let mutable x = [] in + for i = 1 to y do exclave_ + for j = 1 to y do + x <- local_ ((i*j) :: x) + done + done; + x +;; +[%%expect{| +Line 5, characters 11-30: +5 | x <- local_ ((i*j) :: x) + ^^^^^^^^^^^^^^^^^^^ +Error: This value escapes its region. +|}] + + +(* Test 5: Allowed interactions with locals. *) +let foo5_1 y = (* Assignment of local allowed in same scope *) + let mutable x = [] in + x <- (local_ (y :: x)); + x <- (local_ (y :: x)); + match x with + | [] -> assert false + | (x :: xs) -> x + +let () = assert Int.(equal 42 (foo5_1 42)) + +let foo5_2 y = (* Assignment of local works in _local_ for loop body region *) + let mutable x = [] in + for i = 1 to y do exclave_ + x <- local_ (i :: x) + done; + match x with + | [] -> assert false + | (x :: xs) -> x + +let () = assert Int.(equal 42 (foo5_2 42)) + +let foo5_3 y = (* Assignment of local works in _local_ while body region *) + let mutable x = y in + let i = ref 1 in + while !i <= 10 do exclave_ + x <- (local_ (x + !i)); + i := !i + 1; + done; x + +let foo5_4 y = (* Assign of local works in _local_ while cond region *) + let mutable x = y in + while exclave_ x <- (local_ (x + 1)); x <= 100 do + x <- x + x + done; x + +[%%expect{| +val foo5_1 : 'a -> 'a = +val foo5_2 : int -> int = +val foo5_3 : int -> int = +val foo5_4 : int -> int = +|}] + +(* Test 6: let mutable ... and ... is illegal *) +let foo_6 () = + let mutable x = [] + and z = 3 + in + x <- z :: x; + match x with + | [] -> 0 + | z :: _ -> z + +[%%expect{| +Line 2, characters 14-15: +2 | let mutable x = [] + ^ +Error: Mutable let bindings are not allowed as part of a `let .. and ..' group +|}] + +(* Test 7: mutable and rec don't mix *) +let foo_7_1 () = + let mutable rec x = 1 :: x in + match x with + | [] -> 0 + | _ :: _ -> 1 + +[%%expect{| +Line 2, characters 18-19: +2 | let mutable rec x = 1 :: x in + ^ +Error: Mutable let bindings are not allowed to be recursive +|}] + +(* Test 8: only variable patterns may be mutable *) +let foo_8_1 y = + let mutable (x1,x2) = (y,y+1) in + x1 <- x1 + 10; + x2 <- x2 + 20; + (x1,x2) + +[%%expect {| +Line 2, characters 14-21: +2 | let mutable (x1,x2) = (y,y+1) in + ^^^^^^^ +Error: Only variables are allowed as the left-hand side of "let mutable" +|}] + +type t8_2 = {x_8_2 : int} +let foo_8_2 y = + let mutable {x_8_2} = {x_8_2 = y + 1} in + x_8_2 <- x_8_2 + 10; + x_8_2 + + +[%%expect{| +type t8_2 = { x_8_2 : int; } +Line 3, characters 14-21: +3 | let mutable {x_8_2} = {x_8_2 = y + 1} in + ^^^^^^^ +Error: Only variables are allowed as the left-hand side of "let mutable" +|}] + +(* Test 11: binding a mutable variable shouldn't be simplified away *) +let f_11 () = + let mutable x = 10 in + let y = x in + x <- x + 10; + (y,x) + +let () = assert (f_11 () = (10,20)) +[%%expect{| +val f_11 : unit -> int * int = +|}] + +(* Test 12: like Test 11, but with a constructor *) +type t_12 = Foo_12 of int + +let y_12 = + let mutable x = 42 in + let y = Foo_12 x in + x <- 84; y +;; +[%%expect{| +type t_12 = Foo_12 of int +val y_12 : t_12 = Foo_12 42 +|}] + +(* Test 13.1: Can't put aliased in unique mutable variable *) +let reset_ref (x @ unique) = x := 0;; +let x_13_1 = + let y = ref 3 in + let mutable x @ unique = { contents = 1 } in + x <- y; + reset_ref x; + !y +;; +[%%expect{| +val reset_ref : int ref @ unique -> unit = +Line 5, characters 7-8: +5 | x <- y; + ^ +Error: This value is "aliased" but expected to be "unique". +|}] + +(* Test 13.2: Unique mutable variable *) +let x_13_2 = + let mutable x @ unique = { contents = 1 } in + reset_ref x; + !x +;; +[%%expect{| +val x_13_2 : int = 0 +|}] + +(* Test 13.3: Can't put a global in a local record *) +let x_13_3 = ref 0 +let y_13_3 = + let mutable x @ local = ref (ref 0) in + x := x_13_3; + x <- ref x_13_3; + !x +[%%expect{| +val x_13_3 : int ref = {contents = 0} + +Error: This value is "global" bet expected to be "local". +|}] + +(* Test 14: mutable functions *) +let x_14 = + let mutable f = fun x -> 2*x in + let y = f 1 in + f <- (fun x -> 3*x); + let z = f 10 in + y + z +;; +[%%expect{| +val x_14 : int = 32 +|}] + +(* Test 15: mutable unboxed floats *) +let r_15 = + let open Stdlib_upstream_compatible.Float_u in + let mutable r = #256.0 in + for i = 1 to 10 do + r <- div r #2.0 + done; + to_float r +;; +(* 2^8 / 2^10 = 2^-2 *) +[%%expect{| +val r_15 : float = 0.25 +|}] + +(* Test 16: mutable variables must be representable *) +type t_16 : any;; +let f_16 () = let mutable x = (assert false : t_16) in ();; +[%%expect{| +type t_16 : any +Line 2, characters 30-51: +2 | let f_16 () = let mutable x = (assert false : t_16) in ();; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "t_16" but an expression was expected of type + "('a : '_representable_layout_1)" + The layout of t_16 is any + because of the definition of t_16 at line 1, characters 0-15. + But the layout of t_16 must be representable + because it's the type of a variable bound by a `let`. +|}, Principal{| +type t_16 : any +Line 2, characters 26-27: +2 | let f_16 () = let mutable x = (assert false : t_16) in ();; + ^ +Error: This pattern matches values of type "t_16" + but a pattern was expected which matches values of type + "('a : '_representable_layout_1)" + The layout of t_16 is any + because of the definition of t_16 at line 1, characters 0-15. + But the layout of t_16 must be representable + because it's the type of a variable bound by a `let`. +|}] + +(* Test 17: mutable variables can't change type *) +let x_17 = + let mutable x = 3.0 in + x <- 3; + x +;; +[%%expect{| +Line 3, characters 7-8: +3 | x <- 3; + ^ +Error: This expression has type "int" but an expression was expected of type + "float" + Hint: Did you mean "3."? +|}] diff --git a/testsuite/tests/typing-misc/typecore_errors.ml b/testsuite/tests/typing-misc/typecore_errors.ml index 4d28a250b5e..7fb4ccf5b8c 100644 --- a/testsuite/tests/typing-misc/typecore_errors.ml +++ b/testsuite/tests/typing-misc/typecore_errors.ml @@ -182,7 +182,7 @@ let x = object(self) method m = self <-0 end Line 1, characters 32-40: 1 | let x = object(self) method m = self <-0 end ^^^^^^^^ -Error: The value "self" is not an instance variable +Error: The value "self" is not an instance variable or mutable variable |}] (** Multiply override *) @@ -388,7 +388,7 @@ let o = object method m = instance <- 0 end Line 3, characters 26-39: 3 | let o = object method m = instance <- 0 end ^^^^^^^^^^^^^ -Error: Unbound instance variable "instance" +Error: Unbound instance variable or mutable variable "instance" |}] diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml index 819d49f70e0..af4d706a1e8 100644 --- a/tools/eqparsetree.ml +++ b/tools/eqparsetree.ml @@ -735,7 +735,7 @@ and eq_expression_desc : (eq_expression (a0, b0)) && (eq_string (a1, b1)) | (Pexp_new a0, Pexp_new b0) -> Asttypes.eq_loc Longident.eq_t (a0, b0) - | (Pexp_setinstvar (a0, a1), Pexp_setinstvar (b0, b1)) -> + | (Pexp_setvar (a0, a1), Pexp_setvar (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_expression (a1, b1)) | (Pexp_override a0, Pexp_override b0) -> diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 699a9cfb556..6be3ef19462 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -277,7 +277,7 @@ and rw_exp iflag sexp = | Pexp_new _ -> () - | Pexp_setinstvar (_, sarg) -> + | Pexp_setvar (_, sarg) -> rewrite_exp iflag sarg | Pexp_override l -> diff --git a/typing/env.ml b/typing/env.ml index 4e11b696071..8a29ebdb692 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -322,7 +322,6 @@ type shared_context = | For_loop | While_loop | Letop - | Closure | Comprehension | Class | Module @@ -785,8 +784,8 @@ type lookup_error = | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t - | Unbound_instance_variable of string - | Not_an_instance_variable of string + | Unbound_settable_variable of string + | Not_a_settable_variable of string | Masked_instance_variable of Longident.t | Masked_self_variable of Longident.t | Masked_ancestor_variable of Longident.t @@ -805,6 +804,8 @@ type lookup_error = | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t | No_unboxed_version of Longident.t * type_declaration | Error_from_persistent_env of Persistent_env.error + | Mutable_value_used_in_closure of + [`Escape of escaping_context | `Shared of shared_context | `Closure] type error = | Missing_module of Location.t * Path.t * Path.t @@ -829,6 +830,18 @@ let mode_default mode = { context = None } +(* CR jrayman: maybe not the best place to put these *) +let modalities_for_mutvar = + Typemode.transl_modalities ~maturity:Stable + ~for_mutable_variable:true (Mutable mutability_for_mutvar) [] + +let m0_for_mutvar = + Mode.Alloc.Const.merge + {comonadic = mutability_for_mutvar; + monadic = Mode.Alloc.Monadic.Const.min} + |> Mode.Const.alloc_as_value |> Mode.Value.of_const + |> Mode.Modality.Value.Const.apply modalities_for_mutvar + let env_labels (type rep) (record_form : rep record_form) env : rep gen_label_description TycompTbl.t = match record_form with @@ -3300,9 +3313,45 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks = vmode ) vmode locks +(** Take the parameter of [mutable(m0)] at declaration site, *) +let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks = + List.fold_left + (fun (mode : Mode.Value.r) lock -> + match lock with + | Region_lock -> + (* If [m0] is [global], then inside the region we require new values + to be [global]. If [m0] is [local], morally inside the region we can + require new values to be [regional]. However, GC doesn't support + backward pointers inside a single stack frame. So we just require + new values to be [global]. + *) + Mode.Value.meet + [mode; + Mode.Value.max_with (Comonadic Areality) (Mode.Regionality.global)] + | Exclave_lock -> + (* If [m0] is [global], then inside the exclave we require new values + to be [global]. If [m0] is [local], then we require the new values to + be [local]. *) + mode + | Escape_lock (Letop | Probe | Class | Module as ctx) -> + may_lookup_error errors loc env (Mutable_value_used_in_closure (`Escape ctx)) + | Share_lock (Letop | Probe | Class | Module as ctx) -> + may_lookup_error errors loc env (Mutable_value_used_in_closure (`Shared ctx)) + | Share_lock (For_loop | While_loop | Comprehension) -> + mode + | Closure_lock _ -> + may_lookup_error errors loc env (Mutable_value_used_in_closure `Closure) + | Unboxed_lock -> mode + ) mode locks + let lookup_ident_value ~errors ~use ~loc name env = match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with | Ok (path, locks, Val_bound vda) -> + begin match vda with + | {vda_description={val_kind=Val_mut _; _}; _} -> + walk_locks_for_mutable_mode ~errors ~loc ~env m0_for_mutvar locks + |> ignore + | _ -> () end; use_value ~use ~loc path vda; path, locks, vda | Ok (_, _, Val_unbound reason) -> @@ -4037,27 +4086,44 @@ let lookup_all_labels_from_type ?(use=true) ~record_form ~loc usage ty_path env = lookup_all_labels_from_type ~use ~record_form ~loc usage ty_path env -let lookup_instance_variable ?(use=true) ~loc name env = +type settable_variable = + | Instance_variable of Path.t * Asttypes.mutable_flag * string * type_expr + | Mutable_variable of Ident.t * Mode.Value.r * type_expr * Jkind.Sort.t + +let lookup_settable_variable ?(use=true) ~loc name env = match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with - | Ok (path, _, Val_bound vda) -> begin + | Ok (path, locks, Val_bound vda) -> begin let desc = vda.vda_description in - match desc.val_kind with - | Val_ivar(mut, cl_num) -> + match desc.val_kind, path with + | Val_ivar(mut, cl_num), _ -> use_value ~use ~loc path vda; - path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type - | _ -> - lookup_error loc env (Not_an_instance_variable name) + Instance_variable + (path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type) + | Val_mut sort, Pident id -> + let val_type = Subst.Lazy.force_type_expr desc.val_type in + let mode = + walk_locks_for_mutable_mode + ~errors:true ~loc ~env + m0_for_mutvar locks + in + use_value ~use ~loc path vda; + Mutable_variable (id, mode, val_type, sort) + | Val_mut _, _ -> assert false + (* Unreachable because only [type_pat] creates mutable variables + and it checks that they are simple identifiers. *) + | ((Val_reg | Val_prim _ | Val_self _ | Val_anc _), _) -> + lookup_error loc env (Not_a_settable_variable name) end | Ok (_, _, Val_unbound Val_unbound_instance_variable) -> lookup_error loc env (Masked_instance_variable (Lident name)) | Ok (_, _, Val_unbound Val_unbound_self) -> - lookup_error loc env (Not_an_instance_variable name) + lookup_error loc env (Not_a_settable_variable name) | Ok (_, _, Val_unbound Val_unbound_ancestor) -> - lookup_error loc env (Not_an_instance_variable name) + lookup_error loc env (Not_a_settable_variable name) | Ok (_, _, Val_unbound Val_unbound_ghost_recursive _) -> - lookup_error loc env (Unbound_instance_variable name) + lookup_error loc env (Unbound_settable_variable name) | Error _ -> - lookup_error loc env (Unbound_instance_variable name) + lookup_error loc env (Unbound_settable_variable name) (* Checking if a name is bound *) @@ -4354,11 +4420,11 @@ let extract_modtypes path env = fold_modtypes (fun name _ _ acc -> name :: acc) path env [] let extract_cltypes path env = fold_cltypes (fun name _ _ acc -> name :: acc) path env [] -let extract_instance_variables env = +let extract_settable_variables env = fold_values (fun name _ descr _ acc -> match descr.val_kind with - | Val_ivar _ -> name :: acc + | Val_ivar _ | Val_mut _ -> name :: acc | _ -> acc) None env [] let string_of_escaping_context : escaping_context -> string = @@ -4373,7 +4439,6 @@ let string_of_shared_context : shared_context -> string = | For_loop -> "a for loop" | While_loop -> "a while loop" | Letop -> "a letop" - | Closure -> "a closure that is not once" | Comprehension -> "a comprehension" | Class -> "a class" | Module -> "a module" @@ -4400,11 +4465,6 @@ let sharedness_hint ppf : shared_context -> _ = function Format.fprintf ppf "@[Hint: This identifier cannot be used uniquely,@ \ because it is defined in a class.@]" - | Closure -> - Format.fprintf ppf - "@[Hint: This identifier was defined outside of the current closure.@ \ - Either this closure has to be once, or the identifier can be used only@ \ - as aliased.@]" | Module -> Format.fprintf ppf "@[Hint: This identifier cannot be used uniquely,@ \ @@ -4528,13 +4588,14 @@ let report_lookup_error _loc env ppf = function fprintf ppf "Unbound class type %a" (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_cltypes env lid - | Unbound_instance_variable s -> - fprintf ppf "Unbound instance variable %a" Style.inline_code s; - spellcheck_name ppf extract_instance_variables env s; - | Not_an_instance_variable s -> - fprintf ppf "The value %a is not an instance variable" + | Unbound_settable_variable s -> + fprintf ppf "Unbound instance variable or mutable variable %a" Style.inline_code s; - spellcheck_name ppf extract_instance_variables env s; + spellcheck_name ppf extract_settable_variables env s + | Not_a_settable_variable s -> + fprintf ppf "The value %a is not an instance variable or mutable variable" + Style.inline_code s; + spellcheck_name ppf extract_settable_variables env s | Masked_instance_variable lid -> fprintf ppf "The instance variable %a@ \ @@ -4659,6 +4720,15 @@ let report_lookup_error _loc env ppf = function end | Error_from_persistent_env err -> Persistent_env.report_error ppf err + | Mutable_value_used_in_closure ctx -> + let ctx = + match ctx with + | `Escape ctx -> string_of_escaping_context ctx + | `Shared ctx -> string_of_shared_context ctx + | `Closure -> "closure" + in + fprintf ppf + "@[Mutable variable cannot be used inside %s.@]" ctx let report_error ppf = function | Missing_module(_, path1, path2) -> diff --git a/typing/env.mli b/typing/env.mli index bad3329b35d..0c4f89bb61d 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -202,7 +202,6 @@ type shared_context = | For_loop | While_loop | Letop - | Closure | Comprehension | Class | Module @@ -238,8 +237,8 @@ type lookup_error = | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t - | Unbound_instance_variable of string - | Not_an_instance_variable of string + | Unbound_settable_variable of string + | Not_a_settable_variable of string | Masked_instance_variable of Longident.t | Masked_self_variable of Longident.t | Masked_ancestor_variable of Longident.t @@ -257,6 +256,9 @@ type lookup_error = | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t | No_unboxed_version of Longident.t * type_declaration | Error_from_persistent_env of Persistent_env.error + | Mutable_value_used_in_closure of + [`Escape of escaping_context | `Shared of shared_context | `Closure] + val lookup_error: Location.t -> t -> lookup_error -> 'a @@ -278,6 +280,8 @@ type actual_mode = { (** Explains why [mode] is high. *) } +val modalities_for_mutvar : Mode.Modality.Value.Const.t + (** Takes the [mode] and [ty] of a value at definition site, walks through the list of locks and constrains [mode] and [ty]. Return the access mode of the value allowed by the locks. [ty] is optional as the function works on modules and classes as well, for @@ -337,9 +341,12 @@ val lookup_all_labels_from_type: ?use:bool -> record_form:'rcd record_form -> loc:Location.t -> label_usage -> Path.t -> t -> ('rcd gen_label_description * (unit -> unit)) list -val lookup_instance_variable: - ?use:bool -> loc:Location.t -> string -> t -> - Path.t * Asttypes.mutable_flag * string * type_expr +type settable_variable = + | Instance_variable of Path.t * Asttypes.mutable_flag * string * type_expr + | Mutable_variable of Ident.t * Mode.Value.r * type_expr * Jkind.Sort.t + +val lookup_settable_variable: + ?use:bool -> loc:Location.t -> string -> t -> settable_variable val find_value_by_name: Longident.t -> t -> Path.t * value_description diff --git a/typing/jkind.ml b/typing/jkind.ml index 7da49f17852..fa43fdc8169 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -2810,6 +2810,8 @@ module Format_history = struct representable at call sites)" | Peek_or_poke -> fprintf ppf "it's the type being used for a peek or poke primitive" + | Mutable_var_assignment -> + fprintf ppf "it's the type of a mutable variable used in an assignment" let format_concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function @@ -3609,6 +3611,7 @@ module Debug_printers = struct | Layout_poly_in_external -> fprintf ppf "Layout_poly_in_external" | Unboxed_tuple_element -> fprintf ppf "Unboxed_tuple_element" | Peek_or_poke -> fprintf ppf "Peek_or_poke" + | Mutable_var_assignment -> fprintf ppf "Mutable_var_assignment" let concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index f02f7e5d924..4528352000a 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -208,6 +208,7 @@ module History = struct | Layout_poly_in_external | Unboxed_tuple_element | Peek_or_poke + | Mutable_var_assignment (* For sort variables that are in the "legacy" position on the jkind lattice, defaulting exactly to [value]. *) diff --git a/typing/printtyped.ml b/typing/printtyped.ml index c2898532285..0aa71214bec 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -492,11 +492,16 @@ and expression i ppf x = match x.exp_desc with | Texp_ident (li,_,_,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li; + | Texp_mutvar id -> line i ppf "Texp_mutvar %a\n" fmt_ident id.txt; | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; | Texp_let (rf, l, e) -> line i ppf "Texp_let %a\n" fmt_rec_flag rf; list i (value_binding rf) ppf l; expression i ppf e; + | Texp_letmutable (vb, e) -> + line i ppf "Texp_letmutable\n"; + value_binding Nonrecursive i ppf vb; + expression i ppf e | Texp_function { params; body; alloc_mode = am } -> line i ppf "Texp_function\n"; alloc_mode i ppf am; @@ -616,6 +621,9 @@ and expression i ppf x = | Texp_setinstvar (_, s, _, e) -> line i ppf "Texp_setinstvar %a\n" fmt_path s; expression i ppf e; + | Texp_setmutvar (lid, _, e) -> + line i ppf "Texp_setmutvar %a\n" fmt_ident lid.txt; + expression i ppf e; | Texp_override (_, l) -> line i ppf "Texp_override\n"; list i string_x_expression ppf l; diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 8003348343b..b5234fef862 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -339,6 +339,9 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_let (rec_flag, list, exp) -> sub.value_bindings sub (rec_flag, list); sub.expr sub exp + | Texp_letmutable (vb, exp) -> + sub.value_binding sub vb; + sub.expr sub exp | Texp_function { params; body; _ } -> List.iter (function_param sub) params; function_body sub body @@ -416,9 +419,13 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub exp | Texp_new (_, lid, _, _) -> iter_loc sub lid | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_mutvar id -> iter_loc sub id | Texp_setinstvar (_, _, s, exp) -> iter_loc sub s; sub.expr sub exp + | Texp_setmutvar (id, _, exp) -> + iter_loc sub id; + sub.expr sub exp | Texp_override (_, list) -> List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list | Texp_letmodule (_, s, _, mexpr, exp) -> diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index de97924586a..071bc191574 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -464,6 +464,8 @@ let expr sub x = | Texp_let (rec_flag, list, exp) -> let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_letmutable (vb, exp) -> + Texp_letmutable (sub.value_binding sub vb, sub.expr sub exp) | Texp_function { params; body; alloc_mode; ret_mode; ret_sort; zero_alloc } -> let params = List.map (function_param sub) params in @@ -575,6 +577,7 @@ let expr sub x = path2, map_loc sub id ) + | Texp_mutvar id -> Texp_mutvar (map_loc sub id) | Texp_setinstvar (path1, path2, id, exp) -> Texp_setinstvar ( path1, @@ -582,6 +585,8 @@ let expr sub x = map_loc sub id, sub.expr sub exp ) + | Texp_setmutvar (id, sort, exp) -> + Texp_setmutvar (map_loc sub id, sort, sub.expr sub exp) | Texp_override (path, list) -> Texp_override ( path, diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 91b80e52d08..42c7ac9ab36 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1434,7 +1434,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = } | Pcl_let (rec_flag, sdefs, scl') -> let (defs, val_env) = - Typecore.type_let In_class_def val_env rec_flag sdefs in + Typecore.type_let In_class_def val_env Immutable rec_flag sdefs in let (vals, met_env) = List.fold_right (fun (id, modes_and_sorts, _) (vals, met_env) -> diff --git a/typing/typecore.ml b/typing/typecore.ml index 2a61b8563a1..86a9f9c93b6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -142,6 +142,10 @@ let print_unsupported_stack_allocation ppf = function | List_comprehension -> Format.fprintf ppf "list comprehensions" | Array_comprehension -> Format.fprintf ppf "array comprehensions" +type mutable_restriction = + | In_group + | In_rec + type error = | Constructor_arity_mismatch of Longident.t * int * int | Constructor_labeled_arg @@ -223,6 +227,7 @@ type error = | Cannot_infer_signature | Not_a_packed_module of type_expr | Unexpected_existential of existential_restriction * string + | Unexpected_mutable of mutable_restriction | Invalid_interval | Invalid_for_loop_index | Invalid_comprehension_for_range_iterator_index @@ -244,6 +249,7 @@ type error = | Float32_literal of string | Illegal_letrec_pat | Illegal_letrec_expr + | Illegal_mutable_pat | Illegal_class_expr | Letop_type_clash of string * Errortrace.unification_error | Andop_type_clash of string * Errortrace.unification_error @@ -276,6 +282,7 @@ type error = | Function_type_not_rep of type_expr * Jkind.Violation.t | Record_projection_not_rep of type_expr * Jkind.Violation.t | Record_not_rep of type_expr * Jkind.Violation.t + | Mutable_var_not_rep of type_expr * Jkind.Violation.t | Invalid_label_for_src_pos of arg_label | Nonoptional_call_pos_label of string | Cannot_stack_allocate of Env.locality_context option @@ -1151,6 +1158,7 @@ type pattern_variable = pv_id: Ident.t; pv_uid: Uid.t; pv_mode: Value.l; + pv_mutable: mutable_flag; pv_type: type_expr; pv_loc: Location.t; pv_as_var: bool; @@ -1247,13 +1255,32 @@ let maybe_add_pattern_variables_ghost loc_let env pv = let iter_pattern_variables_type f : pattern_variable list -> unit = List.iter (fun {pv_type; _} -> f pv_type) +let iter_pattern_variables_type_mut ~f_immut ~f_mut pvs = + List.iter (fun {pv_type; pv_mutable} -> + match pv_mutable with + | Immutable -> f_immut pv_type + | Mutable -> f_mut pv_type) pvs + let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} - env -> + (fun {pv_id; pv_mode; pv_type; pv_loc; pv_as_var; + pv_mutable; pv_attributes; pv_uid} env -> let check = if pv_as_var then check_as else check in + let kind = match pv_mutable with + | Immutable -> Val_reg + | Mutable -> + Val_mut + (* CR-someday let_mutable: move the sort calculation elsewhere *) + (match + Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment + ~fixed:false env pv_type + with + | Ok sort -> sort + | Error err -> raise(Error(pv_loc, env, + Mutable_var_not_rep(pv_type, err)))) + in Env.add_value ?check ~mode:pv_mode pv_id - {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; + {val_type = pv_type; val_kind = kind; Types.val_loc = pv_loc; val_attributes = pv_attributes; val_modalities = Modality.Value.id; val_zero_alloc = Zero_alloc.default; val_uid = pv_uid @@ -1301,7 +1328,7 @@ let add_module_variables env module_variables = ) env module_variables_as_list let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name mode - ty attrs = + mutable_flag ty attrs = if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt) tps.tps_pattern_variables then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); @@ -1335,6 +1362,7 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name mode tps.tps_pattern_variables <- {pv_id = id; pv_mode = Value.disallow_right mode; + pv_mutable = mutable_flag; pv_type = ty; pv_loc = loc; pv_as_var = is_as_variable; @@ -1954,7 +1982,9 @@ let type_for_loop_index ~loc ~env ~param = let pv_id = Ident.create_local txt in let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let pv = - { pv_id; pv_uid; pv_mode=Value.disallow_right pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes } + { pv_id; pv_uid; pv_mode=Value.disallow_right pv_mode; + pv_mutable=Immutable; pv_type; pv_loc; pv_as_var; + pv_attributes } in (pv_id, pv_uid), add_pattern_variables ~check ~check_as:check env [pv]) @@ -1975,9 +2005,30 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = pv_loc name pv_mode + Immutable pv_type pv_attributes) +let check_let_mutable (mf : mutable_flag) env ?restriction vbs = + match vbs, mf with + | vb :: vbs, Mutable -> begin + let loc = vb.pvb_pat.ppat_loc in + (* If the [let] is [mutable], check: + - Let_mutable is enabled + - There is only one value binding + - The value binding pattern consists only of a variable, possibly + with a type/mode constraint + - Mutables are not restricted here according to [restriction] *) + Language_extension.assert_enabled ~loc Let_mutable (); + match restriction, vb.pvb_pat.ppat_desc, vbs with + | _, _, _ :: _ -> raise (Error (loc, env, Unexpected_mutable In_group)) + | Some r, _, _ -> raise (Error (loc, env, Unexpected_mutable r)) + | None, Ppat_var _, [] -> () + | None, (Ppat_constraint ({ppat_desc=Ppat_var _}, _, _)), [] -> () + | None, _, [] -> raise (Error (loc, env, Illegal_mutable_pat)) + end + | _ -> () +;; (* Type paths *) @@ -2607,22 +2658,25 @@ let components_have_label (labeled_components : (string option * 'a) list) = let rec type_pat : type k . type_pat_state -> k pattern_category -> no_existentials: existential_restriction option -> - alloc_mode:expected_pat_mode -> + alloc_mode:expected_pat_mode -> mutable_flag:_ -> penv: Pattern_env.t -> Parsetree.pattern -> type_expr -> k general_pattern - = fun tps category ~no_existentials ~alloc_mode ~penv sp expected_ty -> + = fun tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv sp + expected_ty -> Builtin_attributes.warning_scope sp.ppat_attributes (fun () -> type_pat_aux tps category ~no_existentials - ~alloc_mode ~penv sp expected_ty + ~alloc_mode ~mutable_flag ~penv sp expected_ty ) and type_pat_aux : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> - alloc_mode:expected_pat_mode -> penv:_ -> _ -> _ -> k general_pattern - = fun tps category ~no_existentials ~alloc_mode ~penv sp expected_ty -> + alloc_mode:expected_pat_mode -> mutable_flag:_ -> penv:_ -> _ -> + _ -> k general_pattern + = fun tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv sp + expected_ty -> let type_pat tps category ?(alloc_mode=alloc_mode) ?(penv=penv) = - type_pat tps category ~no_existentials ~alloc_mode ~penv + type_pat tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv in let loc = sp.ppat_loc in let solve_expected (x : pattern) : pattern = @@ -2812,7 +2866,8 @@ and type_pat_aux cross_left !!penv expected_ty alloc_mode.mode in let id, uid = - enter_variable tps loc name alloc_mode ty sp.ppat_attributes + enter_variable tps loc name alloc_mode mutable_flag ty + sp.ppat_attributes in rvp { pat_desc = Tpat_var (id, name, uid, alloc_mode); @@ -2838,7 +2893,7 @@ and type_pat_aux (* We're able to pass ~is_module:true here without an error because [Ppat_unpack] is a case identified by [may_contain_modules]. See the comment on [may_contain_modules]. *) - let id, uid = enter_variable tps loc v alloc_mode.mode + let id, uid = enter_variable tps loc v alloc_mode.mode mutable_flag t ~is_module:true sp.ppat_attributes in rvp { pat_desc = Tpat_var (id, v, uid, alloc_mode.mode); @@ -2854,8 +2909,8 @@ and type_pat_aux let ty_var, mode = solve_Ppat_alias ~mode:alloc_mode.mode !!penv q in let mode = cross_left !!penv expected_ty mode in let id, uid = - enter_variable ~is_as_variable:true tps name.loc name mode ty_var - sp.ppat_attributes + enter_variable ~is_as_variable:true tps name.loc name mode mutable_flag + ty_var sp.ppat_attributes in rvp { pat_desc = Tpat_alias(q, id, name, uid, mode, ty_var); pat_loc = loc; pat_extra=[]; @@ -3140,14 +3195,17 @@ and type_pat_aux | Ppat_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -let type_pat tps category ?no_existentials penv = - type_pat tps category ~no_existentials ~penv +let type_pat tps category ?no_existentials ~mutable_flag penv = + type_pat tps category ~no_existentials ~mutable_flag ~penv let type_pattern category ~lev ~alloc_mode env spat expected_ty allow_modules = let tps = create_type_pat_state allow_modules in let new_penv = Pattern_env.make env ~equations_scope:lev ~allow_recursive_equations:false in - let pat = type_pat tps category ~alloc_mode new_penv spat expected_ty in + let pat = + type_pat tps category ~alloc_mode ~mutable_flag:Immutable new_penv spat + expected_ty + in let { tps_pattern_variables = pvs; tps_module_variables = mvs; tps_pattern_force = forces; @@ -3155,7 +3213,7 @@ let type_pattern category ~lev ~alloc_mode env spat expected_ty allow_modules = (pat, !!new_penv, forces, pvs, mvs) let type_pattern_list - category no_existentials env spatl expected_tys allow_modules + category mutable_flag no_existentials env spatl expected_tys allow_modules = let tps = create_type_pat_state allow_modules in let equations_scope = get_current_level () in @@ -3166,7 +3224,8 @@ let type_pattern_list (fun () -> exp_mode, type_pat tps category - ~no_existentials ~alloc_mode:pat_mode new_penv pat ty + ~no_existentials ~alloc_mode:pat_mode ~mutable_flag + new_penv pat ty ) in let patl = List.map2 type_pat spatl expected_tys in @@ -3187,7 +3246,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = ~equations_scope ~allow_recursive_equations:false in let pat = type_pat tps Value ~no_existentials:In_class_args ~alloc_mode - new_penv spat nv in + ~mutable_flag:Immutable new_penv spat nv in if has_variants pat then begin Parmatch.pressure_variants val_env [pat]; finalize_variants pat; @@ -3250,7 +3309,7 @@ let type_self_pattern env spat = ~equations_scope ~allow_recursive_equations:false in let pat = type_pat tps Value ~no_existentials:In_self_pattern ~alloc_mode - new_penv spat nv in + ~mutable_flag:Immutable new_penv spat nv in List.iter (fun f -> f()) tps.tps_pattern_force; pat, tps.tps_pattern_variables @@ -4177,6 +4236,8 @@ let rec is_nonexpansive exp = | Texp_let(_rec_flag, pat_exp_list, body) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body + | Texp_letmutable(pat_exp, body) -> + is_nonexpansive pat_exp.vb_expr && is_nonexpansive body | Texp_apply(e, (_,Omitted _)::el, _, _, _) -> is_nonexpansive e && List.for_all is_nonexpansive_arg (List.map snd el) | Texp_match(e, _, cases, _) -> @@ -4271,7 +4332,9 @@ let rec is_nonexpansive exp = | Texp_for _ | Texp_send _ | Texp_instvar _ + | Texp_mutvar _ | Texp_setinstvar _ + | Texp_setmutvar _ | Texp_override _ | Texp_letexception _ | Texp_letop _ @@ -4506,7 +4569,7 @@ let type_approx_fun_one_param let rec type_approx env sexp ty_expected = let loc = sexp.pexp_loc in match sexp.pexp_desc with - Pexp_let (_, _, e) -> type_approx env e ty_expected + Pexp_let (_, _, _, e) -> type_approx env e ty_expected | Pexp_function (params, c, body) -> type_approx_function env params c body ty_expected ~loc | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e ty_expected @@ -4725,6 +4788,7 @@ let check_partial_application ~statement exp = | Texp_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_while _ | Texp_for _ | Texp_instvar _ + | Texp_mutvar _ | Texp_setmutvar _ | Texp_setinstvar _ | Texp_override _ | Texp_assert _ | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) @@ -4737,7 +4801,8 @@ let check_partial_application ~statement exp = check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases | Texp_ifthenelse (_, e1, Some e2) -> check e1; check e2 - | Texp_let (_, _, e) | Texp_sequence (_, _, e) | Texp_open (_, e) + | Texp_let (_, _, e) | Texp_letmutable(_, e) + | Texp_sequence (_, _, e) | Texp_open (_, e) | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) | Texp_exclave e -> check e @@ -5327,7 +5392,7 @@ let vb_pat_constraint in vb.pvb_attributes, spat -let pat_modes ~force_toplevel rec_mode_var (attrs, spat) = +let pat_modes ~force_toplevel ~mutable_flag rec_mode_var (attrs, spat) = let pat_mode, exp_mode = if force_toplevel then simple_pat_mode Value.legacy, mode_legacy @@ -5345,7 +5410,13 @@ let pat_modes ~force_toplevel rec_mode_var (attrs, spat) = | Some mode -> simple_pat_mode mode, mode_default mode in - attrs, pat_mode, exp_mode, spat + match (mutable_flag : mutable_flag) with + | Mutable + | Immutable -> attrs, pat_mode, exp_mode, spat + (* check_construct_mutability for exp_mode *) + (* [apply modalities] to [exp_mode] to get expected mode of content of cell *) + (* modalities to apply: Typemode.mutable_implied_modalities, only monadic *) + (* How do I get a ty here? *) let add_zero_alloc_attribute expr attributes = let open Builtin_attributes in @@ -5693,6 +5764,18 @@ and type_expect_ match lid.txt with Longident.Lident txt -> { txt; loc = lid.loc } | _ -> assert false) + | Val_mut _ -> begin + match path with + | Path.Pident id -> + submode ~loc ~env + (Mode.Modality.Value.Const.apply + Env.modalities_for_mutvar actual_mode.mode) + expected_mode; + Texp_mutvar {loc = lid.loc; txt = id} + | _ -> + fatal_error "Typecore.type_expect_: \ + bad mutable variable identifier" + end | Val_self (_, _, _, cl_num) -> let (path, _) = Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env @@ -5750,7 +5833,7 @@ and type_expect_ exp_type = type_constant cst; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_let(Nonrecursive, + | Pexp_let(Immutable, Nonrecursive, [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) when turn_let_into_match spat -> (* TODO: allow non-empty attributes? *) @@ -5759,8 +5842,13 @@ and type_expect_ {sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} ty_expected_explained - | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let existential_context = + | Pexp_let(mutable_flag, rec_flag, spat_sexp_list, sbody) -> + let restriction = match rec_flag with + | Recursive -> Some In_rec + | Nonrecursive -> None + in + check_let_mutable mutable_flag env ?restriction spat_sexp_list; + let existential_context : existential_restriction = if rec_flag = Recursive then In_rec else if List.compare_length_with spat_sexp_list 1 > 0 then In_group else With_attributes in @@ -5783,8 +5871,8 @@ and type_expect_ else Modules_rejected in let (pat_exp_list, new_env) = - type_let existential_context env rec_flag spat_sexp_list - allow_modules + type_let existential_context env mutable_flag rec_flag + spat_sexp_list allow_modules in let body = type_expect @@ -5827,8 +5915,17 @@ and type_expect_ (* The "body" component of the scope escape check. *) unify_exp new_env body (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) in + let exp = + match mutable_flag, pat_exp_list with + | Immutable, _ -> Texp_let(rec_flag, pat_exp_list, body) + | Mutable, [vb] -> Texp_letmutable(vb, body) + | Mutable, _ -> + (* Unreachable: should be prevented by [check_let_mutable] *) + fatal_error "Typecore.type_expect_: \ + [let mutable] should have exactly one value binding" + in re { - exp_desc = Texp_let(rec_flag, pat_exp_list, body); + exp_desc = exp; exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; @@ -6413,28 +6510,33 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } end - | Pexp_setinstvar (lab, snewval) -> begin - let (path, mut, cl_num, ty) = - Env.lookup_instance_variable ~loc lab.txt env - in - match mut with - | Mutable -> - let newval = - type_expect env mode_legacy snewval - (mk_expected (instance ty)) - in - let (path_self, _) = - Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env - in - rue { - exp_desc = Texp_setinstvar(path_self, path, lab, newval); - exp_loc = loc; exp_extra = []; - exp_type = instance Predef.type_unit; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | _ -> - raise(Error(loc, env, Instance_variable_not_mutable lab.txt)) - end + | Pexp_setvar (lab, snewval) -> + let desc = + match Env.lookup_settable_variable ~loc lab.txt env with + | Instance_variable (path, Mutable, cl_num,ty) -> + let newval = + type_expect env mode_legacy snewval (mk_expected (instance ty)) + in + let (path_self, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + Texp_setinstvar(path_self, path, lab, newval) + | Instance_variable (_,Immutable,_,_) -> + raise(Error(loc, env, Instance_variable_not_mutable lab.txt)) + | Mutable_variable (id, mode, ty, sort) -> + let newval = + type_expect env (mode_default mode) + snewval (mk_expected (instance ty)) + in + let lid = {txt = id; loc} in + Texp_setmutvar(lid, sort, newval) + in + rue { + exp_desc = desc; + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } | Pexp_override lst -> submode ~loc ~env Value.legacy expected_mode; let _ = @@ -9099,7 +9201,7 @@ and type_function_cases_expect (* Typing of let bindings *) and type_let ?check ?check_strict ?(force_toplevel = false) - existential_context env rec_flag spat_sexp_list allow_modules = + existential_context env mutable_flag rec_flag spat_sexp_list allow_modules = let rec sexp_is_fun sexp = match sexp.pexp_desc with | Pexp_function _ -> true @@ -9125,7 +9227,10 @@ and type_let ?check ?check_strict ?(force_toplevel = false) | Nonrecursive -> None in let spatl = List.map vb_pat_constraint spat_sexp_list in - let spatl = List.map (pat_modes ~force_toplevel rec_mode_var) spatl in + let spatl = + List.map + (pat_modes ~force_toplevel ~mutable_flag rec_mode_var) spatl + in let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in let is_recursive = (rec_flag = Recursive) in @@ -9140,8 +9245,8 @@ and type_let ?check ?check_strict ?(force_toplevel = false) in let (pat_list, _new_env, _force, pvs, _mvs as res) = with_local_level_if is_recursive (fun () -> - type_pattern_list Value existential_context env spatl nvs - allow_modules + type_pattern_list Value mutable_flag existential_context env spatl + nvs allow_modules ) ~post:(fun (_, _, _, pvs, _) -> iter_pattern_variables_type generalize pvs) in @@ -9264,7 +9369,10 @@ and type_let ?check ?check_strict ?(force_toplevel = false) (fun (_, pat, _) (exp, _) -> if maybe_expansive exp then lower_contravariant env pat.pat_type) mode_pat_typ_list exp_list; - iter_pattern_variables_type generalize pvs; + iter_pattern_variables_type_mut + ~f_immut:generalize + ~f_mut:(unify_var env (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) + pvs; (* update pattern variable jkind reasons *) List.iter (fun pv -> @@ -9951,6 +10059,7 @@ and type_comprehension_iterator Value ~no_existentials:In_self_pattern ~alloc_mode:(simple_pat_mode Value.legacy) + ~mutable_flag:Immutable penv pattern item_ty @@ -10055,21 +10164,22 @@ let maybe_check_uniqueness_value_bindings vbl = (* Typing of toplevel bindings *) -let type_binding env rec_flag ?force_toplevel spat_sexp_list = +let type_binding env mutable_flag rec_flag ?force_toplevel spat_sexp_list = let (pat_exp_list, new_env) = type_let ~check:(fun s -> Warnings.Unused_value_declaration s) ~check_strict:(fun s -> Warnings.Unused_value_declaration s) ?force_toplevel At_toplevel - env rec_flag spat_sexp_list Modules_rejected + env mutable_flag rec_flag spat_sexp_list Modules_rejected in maybe_check_uniqueness_value_bindings pat_exp_list; (pat_exp_list, new_env) -let type_let existential_ctx env rec_flag spat_sexp_list = +let type_let existential_ctx env mutable_flag rec_flag spat_sexp_list = let (pat_exp_list, new_env) = - type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected + type_let existential_ctx env mutable_flag rec_flag spat_sexp_list + Modules_rejected in maybe_check_uniqueness_value_bindings pat_exp_list; (pat_exp_list, new_env) @@ -10802,6 +10912,16 @@ let report_error ~loc env = Location.errorf ~loc "%t,@ but the constructor %a introduces existential types." reason_str Style.inline_code name + | Unexpected_mutable reason -> + let reason_str = + match reason with + | In_rec -> + "to be recursive" + | In_group -> + "as part of a `let .. and ..' group" + in + Location.errorf ~loc "@[Mutable let bindings are not allowed %s " + reason_str | Invalid_interval -> Location.errorf ~loc "@[Only character intervals are supported in patterns.@]" @@ -10885,6 +11005,10 @@ let report_error ~loc env = Location.errorf ~loc "Only variables are allowed as left-hand side of %a" Style.inline_code "let rec" + | Illegal_mutable_pat -> + Location.errorf ~loc + "Only variables are allowed as the left-hand side of %a" + Style.inline_code "let mutable" | Illegal_letrec_expr -> Location.errorf ~loc "This kind of expression is not allowed as right-hand side of %a" @@ -11102,6 +11226,11 @@ let report_error ~loc env = "@[Record expressions must be representable.@]@ %a" (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation + | Mutable_var_not_rep (ty, violation) -> + Location.errorf ~loc + "@[Mutable variables must be representable.@]@ %a" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation | Invalid_label_for_src_pos arg_label -> Location.errorf ~loc "A position argument must not be %s." diff --git a/typing/typecore.mli b/typing/typecore.mli index 503181e54de..90d137c9e40 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -65,6 +65,7 @@ type pattern_variable = pv_id: Ident.t; pv_uid: Uid.t; pv_mode: Mode.Value.l; + pv_mutable: mutable_flag; pv_type: type_expr; pv_loc: Location.t; pv_as_var: bool; @@ -112,18 +113,22 @@ type existential_restriction = | In_class_def (** or in [class c = let ... in ...] *) | In_self_pattern (** or in self pattern *) +type mutable_restriction = + | In_group + | In_rec + type module_patterns_restriction = | Modules_allowed of { scope: int } | Modules_rejected | Modules_ignored val type_binding: - Env.t -> rec_flag -> + Env.t -> mutable_flag -> rec_flag -> ?force_toplevel:bool -> Parsetree.value_binding list -> Typedtree.value_binding list * Env.t val type_let: - existential_restriction -> Env.t -> rec_flag -> + existential_restriction -> Env.t -> mutable_flag -> rec_flag -> Parsetree.value_binding list -> Typedtree.value_binding list * Env.t val type_expression: @@ -268,6 +273,7 @@ type error = | Cannot_infer_signature | Not_a_packed_module of type_expr | Unexpected_existential of existential_restriction * string + | Unexpected_mutable of mutable_restriction | Invalid_interval | Invalid_for_loop_index | Invalid_comprehension_for_range_iterator_index @@ -290,6 +296,7 @@ type error = | Float32_literal of string | Illegal_letrec_pat | Illegal_letrec_expr + | Illegal_mutable_pat | Illegal_class_expr | Letop_type_clash of string * Errortrace.unification_error | Andop_type_clash of string * Errortrace.unification_error @@ -321,6 +328,7 @@ type error = | Function_type_not_rep of type_expr * Jkind.Violation.t | Record_projection_not_rep of type_expr * Jkind.Violation.t | Record_not_rep of type_expr * Jkind.Violation.t + | Mutable_var_not_rep of type_expr * Jkind.Violation.t | Invalid_label_for_src_pos of arg_label | Nonoptional_call_pos_label of string | Cannot_stack_allocate of Env.locality_context option diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 9157a66e932..b840261a7bf 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -215,6 +215,7 @@ and expression_desc = Path.t * Longident.t loc * Types.value_description * ident_kind * unique_use | Texp_constant of constant | Texp_let of rec_flag * value_binding list * expression + | Texp_letmutable of value_binding * expression | Texp_function of { params : function_param list; body : function_body; @@ -277,7 +278,9 @@ and expression_desc = | Texp_new of Path.t * Longident.t loc * Types.class_declaration * apply_position | Texp_instvar of Path.t * Path.t * string loc + | Texp_mutvar of Ident.t loc | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_setmutvar of Ident.t loc * Jkind.sort * expression | Texp_override of Path.t * (Ident.t * string loc * expression) list | Texp_letmodule of Ident.t option * string option loc * Types.module_presence * module_expr * diff --git a/typing/typedtree.mli b/typing/typedtree.mli index edaa8f8e991..94c7589cc4b 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -322,6 +322,8 @@ and expression_desc = (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) + | Texp_letmutable of value_binding * expression + (** let mutable P = E in E' *) | Texp_function of { params : function_param list; body : function_body; @@ -481,7 +483,9 @@ and expression_desc = | Texp_new of Path.t * Longident.t loc * Types.class_declaration * apply_position | Texp_instvar of Path.t * Path.t * string loc + | Texp_mutvar of Ident.t loc | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_setmutvar of Ident.t loc * Jkind.sort * expression | Texp_override of Path.t * (Ident.t * string loc * expression) list | Texp_letmodule of Ident.t option * string option loc * Types.module_presence * module_expr * diff --git a/typing/typemod.ml b/typing/typemod.ml index 06eb5a73a69..9b91460b5ea 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3100,7 +3100,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = Tstr_eval (expr, sort, attrs), [], shape_map, env | Pstr_value (rec_flag, sdefs) -> let (defs, newenv) = - Typecore.type_binding env rec_flag ~force_toplevel sdefs in + Typecore.type_binding env Immutable rec_flag ~force_toplevel sdefs in let defs = match rec_flag with | Recursive -> Typecore.annotate_recursive_bindings env defs | Nonrecursive -> defs diff --git a/typing/typemode.ml b/typing/typemode.ml index fbf2f546040..d2a901aa361 100644 --- a/typing/typemode.ml +++ b/typing/typemode.ml @@ -465,7 +465,7 @@ let untransl_modality (a : Modality.t) : Parsetree.modality loc = removed. The implications on the monadic axes will stay. Implied modalities can be overriden. *) (* CR zqian: decouple mutable and comonadic modalities *) -let mutable_implied_modalities (mut : Types.mutability) = +let mutable_implied_modalities ~for_mutable_variable (mut : Types.mutability) = let comonadic : Modality.t list = [ Atom (Comonadic Areality, Meet_with Regionality.Const.legacy); Atom (Comonadic Linearity, Meet_with Linearity.Const.legacy); @@ -478,10 +478,12 @@ let mutable_implied_modalities (mut : Types.mutability) = Atom (Monadic Contention, Join_with Contention.Const.legacy); Atom (Monadic Visibility, Join_with Visibility.Const.legacy) ] in - match mut with Immutable -> [] | Mutable _ -> monadic @ comonadic + match mut with + | Immutable -> [] + | Mutable _ -> if for_mutable_variable then monadic else monadic @ comonadic -let mutable_implied_modalities (mut : Types.mutability) = - let l = mutable_implied_modalities mut in +let mutable_implied_modalities ~for_mutable_variable (mut : Types.mutability) = + let l = mutable_implied_modalities ~for_mutable_variable mut in List.fold_left (fun t (Modality.Atom (ax, a)) -> Modality.Value.Const.set ax a t) Modality.Value.Const.id l @@ -516,7 +518,7 @@ let implied_modalities (Atom (ax, a) : Modality.t) : Modality.t list = | _ -> [] let least_modalities_implying mut (t : Modality.Value.Const.t) = - let baseline = mutable_implied_modalities mut in + let baseline = mutable_implied_modalities ~for_mutable_variable:false mut in let annotated = Modality.Value.Const.(diff baseline t) in let implied = List.concat_map implied_modalities annotated in let exclude_implied = @@ -559,8 +561,8 @@ let sort_dedup_modalities ~warn l = in l |> List.stable_sort compare |> dedup ~on_dup |> List.map fst -let transl_modalities ~maturity mut modalities = - let mut_modalities = mutable_implied_modalities mut in +let transl_modalities ~maturity ?(for_mutable_variable=false) mut modalities = + let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable in let modalities = List.map (transl_modality ~maturity) modalities in (* axes listed in the order of implication. *) let modalities = sort_dedup_modalities ~warn:true modalities in diff --git a/typing/typemode.mli b/typing/typemode.mli index d3c01b76b4d..f2a556790b4 100644 --- a/typing/typemode.mli +++ b/typing/typemode.mli @@ -13,6 +13,8 @@ val transl_alloc_mode : Parsetree.modes -> Mode.Alloc.Const.t *) val transl_modalities : maturity:Language_extension.maturity -> + ?for_mutable_variable:bool -> + (* CR jrayman: come up with a better parameter *) Types.mutability -> Parsetree.modalities -> Mode.Modality.Value.Const.t diff --git a/typing/types.ml b/typing/types.ml index 63f43aa5fbd..aa6b9c4f9b9 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -22,6 +22,11 @@ type mutability = | Immutable | Mutable of Mode.Alloc.Comonadic.Const.t +let mutability_for_mutvar = + { Mode.Alloc.Comonadic.Const.legacy with + areality = Mode.Locality.Const.max; + yielding = Mode.Yielding.Const.max } + let is_mutable = function | Immutable -> false | Mutable _ -> true @@ -470,6 +475,8 @@ module Vars = Misc.Stdlib.String.Map type value_kind = Val_reg (* Regular value *) + | Val_mut of Jkind_types.Sort.t + (* Mutable value *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of diff --git a/typing/types.mli b/typing/types.mli index 41003b7c04a..e98e8206813 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -32,6 +32,9 @@ type mutability = | Mutable of Mode.Alloc.Comonadic.Const.t (** The upper bound of the new field value upon mutation. *) +(** [mutability] for mutable variables ... CR jrayman *) +val mutability_for_mutvar : Mode.Alloc.Comonadic.Const.t + (** Returns [true] is the [mutable_flag] is mutable. Should be called if not interested in the payload of [Mutable]. *) val is_mutable : mutability -> bool @@ -643,6 +646,17 @@ module Vars : Map.S with type key = string type value_kind = Val_reg (* Regular value *) + | Val_mut of Jkind_types.Sort.t + (** Mutable value, declared as [let mutable(m0) x = ..]. The mode returned + here is [m0] adjusted for regions, suitable to be used as the expected + mode of the new content. + + Currently, the syntax is not supported and [m0] is fixed to be [local, + legacy]. After adjusting for regions, the mode here could be [global, + legacy]. + + CR jrayman: update comment + *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of class_signature * self_meths * Ident.t Vars.t * string diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml index e6aaf2b9907..414c0193487 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -2138,6 +2138,13 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t = check_uniqueness_exp ~overwrite:None (Ienv.extend ienv ext) body in UF.seq uf_vbs uf_body + | Texp_letmutable (vb, body) -> + (* CR jrayman: not immediately clear this is correct *) + let ext, uf_vbs = check_uniqueness_value_bindings ienv [vb] in + let uf_body = + check_uniqueness_exp ~overwrite:None (Ienv.extend ienv ext) body + in + UF.seq uf_vbs uf_body | Texp_function { params; body; _ } -> let ienv, uf_params = List.fold_left_map @@ -2325,7 +2332,9 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t = | Texp_send (e, _, _) -> check_uniqueness_exp ~overwrite:None ienv e | Texp_new _ -> UF.unused | Texp_instvar _ -> UF.unused + | Texp_mutvar _ -> UF.unused | Texp_setinstvar (_, _, _, e) -> check_uniqueness_exp ~overwrite:None ienv e + | Texp_setmutvar (_, _, e) -> check_uniqueness_exp ~overwrite:None ienv e | Texp_override (_, ls) -> UF.pars (List.map diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 9c4544536a3..114062aeb62 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -493,9 +493,13 @@ let expression sub exp = Texp_ident (_path, lid, _, _, _) -> Pexp_ident (map_loc sub lid) | Texp_constant cst -> Pexp_constant (constant cst) | Texp_let (rec_flag, list, exp) -> - Pexp_let (rec_flag, + Pexp_let (Immutable, rec_flag, List.map (sub.value_binding sub) list, sub.expr sub exp) + | Texp_letmutable (vb, exp) -> + Pexp_let (Mutable, Nonrecursive, + [sub.value_binding sub vb], + sub.expr sub exp) | Texp_function { params; body } -> let body, constraint_ = match body with @@ -632,8 +636,15 @@ let expression sub exp = | Texp_new (_path, lid, _, _) -> Pexp_new (map_loc sub lid) | Texp_instvar (_, path, name) -> Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) + | Texp_mutvar id -> + Pexp_ident ({loc = sub.location sub id.loc; + txt = lident_of_path (Pident id.txt)}) | Texp_setinstvar (_, _path, lid, exp) -> - Pexp_setinstvar (map_loc sub lid, sub.expr sub exp) + Pexp_setvar (map_loc sub lid, sub.expr sub exp) + | Texp_setmutvar(lid, _sort, exp) -> + let lid = {loc = sub.location sub lid.loc; + txt = Ident.name lid.txt} in + Pexp_setvar (lid, sub.expr sub exp) | Texp_override (_, list) -> Pexp_override (List.map (fun (_path, lid, exp) -> (map_loc sub lid, sub.expr sub exp) diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml index c27f9c370f6..5a32230e528 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -150,6 +150,9 @@ let classify_expression : Typedtree.expression -> sd = | Texp_let (rec_flag, vb, e) -> let env = classify_value_bindings rec_flag env vb in classify_expression env e + | Texp_letmutable (vb, e) -> + let env = classify_value_bindings Nonrecursive env [vb] in + classify_expression env e | Texp_letmodule (Some mid, _, _, mexp, e) -> (* Note on module presence: For absent modules (i.e. module aliases), the module being bound @@ -210,6 +213,10 @@ let classify_expression : Typedtree.expression -> sd = (* Unit-returning expressions *) Static + | Texp_mutvar _ + | Texp_setmutvar _ -> + Static + | Texp_unreachable -> Static @@ -637,6 +644,14 @@ let rec expression : Typedtree.expression -> term_judg = G |- let in body : m *) value_bindings rec_flag bindings >> expression body + | Texp_letmutable (binding,body) -> + (* + G |- : m -| G' + G' |- body : m + -------------------------------- + G |- let mutable in body : m + *) + value_bindings Nonrecursive [binding] >> expression body | Texp_letmodule (x, _, _, mexp, e) -> module_binding (x, mexp) >> expression e | Texp_match (e, _, cases, _) -> @@ -675,6 +690,8 @@ let rec expression : Typedtree.expression -> term_judg = path pth << Dereference | Texp_instvar (self_path, pth, _inst_var) -> join [path self_path << Dereference; path pth] + | Texp_mutvar id -> + single id.txt << Dereference | Texp_apply ({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)}, [_, Arg (arg, _)], _, _, _) @@ -886,6 +903,13 @@ let rec expression : Typedtree.expression -> term_judg = path pth << Dereference; expression e << Dereference; ] + | Texp_setmutvar (_id,_sort,e) -> + (* + G |- e: m[Dereference] + ---------------------- + G |- x <- e: m + *) + expression e << Dereference | Texp_letexception ({ext_id}, e) -> (* G |- e: m ---------------------------- diff --git a/utils/language_extension_kernel.ml b/utils/language_extension_kernel.ml index 24b0f86a4b9..14b87d103f0 100644 --- a/utils/language_extension_kernel.ml +++ b/utils/language_extension_kernel.ml @@ -19,6 +19,7 @@ type _ t = | Small_numbers : maturity t | Instances : unit t | Separability : unit t + | Let_mutable : unit t (* When you update this, update [pair_of_string] below too. *) let to_string : type a. a t -> string = function @@ -36,3 +37,4 @@ let to_string : type a. a t -> string = function | Small_numbers -> "small_numbers" | Instances -> "instances" | Separability -> "separability" + | Let_mutable -> "let_mutable" diff --git a/utils/language_extension_kernel.mli b/utils/language_extension_kernel.mli index 75eb647036e..c78788f1ef3 100644 --- a/utils/language_extension_kernel.mli +++ b/utils/language_extension_kernel.mli @@ -30,6 +30,7 @@ type _ t = | Small_numbers : maturity t | Instances : unit t | Separability : unit t + | Let_mutable : unit t (** Print and parse language extensions; parsing is case-insensitive *) val to_string : _ t -> string diff --git a/utils/profile_counters_functions.ml b/utils/profile_counters_functions.ml index dd247d1b4e8..85372d2ad71 100644 --- a/utils/profile_counters_functions.ml +++ b/utils/profile_counters_functions.ml @@ -11,7 +11,7 @@ let count_language_extensions typing_input = | Labeled_tuples -> Language_extension_kernel.to_string lang_ext | Mode | Unique | Polymorphic_parameters | Layouts | SIMD | Small_numbers - | Instances | Overwriting | Separability -> + | Instances | Overwriting | Separability | Let_mutable -> let error_msg = Format.sprintf "No counters supported for language extension : %s." (Language_extension_kernel.to_string lang_ext)