From fac96b24c417dd8878c8a28c844dc286f2b47ed8 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Thu, 24 Apr 2025 16:57:04 -0400 Subject: [PATCH 1/8] Add a test and update the parser for `let mutable` --- ocamldoc/odoc_ast.ml | 3 +- parsing/ast_helper.ml | 6 +- parsing/ast_invariants.ml | 4 +- parsing/ast_iterator.ml | 4 +- parsing/ast_mapper.ml | 6 +- parsing/depend.ml | 6 +- parsing/language_extension.ml | 12 +- parsing/language_extension.mli | 1 + parsing/parser.mly | 10 +- parsing/parser_types.ml | 1 + parsing/parser_types.mli | 1 + parsing/parsetree.mli | 6 +- parsing/pprintast.ml | 15 +- parsing/printast.ml | 8 +- printer/printast_with_mappings.ml | 8 +- testsuite/tests/typing-local/let_mutable.ml | 269 ++++++++++++++++++++ typing/typecore.ml | 7 +- typing/typemod.ml | 3 +- typing/untypeast.ml | 6 +- utils/language_extension_kernel.ml | 2 + utils/language_extension_kernel.mli | 1 + utils/profile_counters_functions.ml | 2 +- 22 files changed, 339 insertions(+), 42 deletions(-) create mode 100644 testsuite/tests/typing-local/let_mutable.ml diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index a5dfba13569..157bcf5adca 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1025,7 +1025,8 @@ module Analyser = | Parsetree.Pstr_attribute _ | Parsetree.Pstr_extension _ -> (0, env, []) - | Parsetree.Pstr_value (rec_flag, pat_exp_list) -> + (* jra: mutable flag should not be ignored *) + | Parsetree.Pstr_value (_, rec_flag, pat_exp_list) -> (* of rec_flag * (pattern * expression) list *) (* For each value, look for the value name, then look in the typedtree for the corresponding information, diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ed0b340b41a..bb4ed69e83b 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -209,7 +209,8 @@ 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)) + (* jra: Immutable should not be hard-coded *) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (Immutable, a, b, c)) 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)) @@ -338,7 +339,8 @@ module Str = struct let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) + (* jra: Immutable should not be hard-coded *) + let value ?loc a b = mk ?loc (Pstr_value (Immutable, a, b)) let primitive ?loc a = mk ?loc (Pstr_primitive a) let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) let type_extension ?loc a = mk ?loc (Pstr_typext a) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index bd82cbe7c69..42b38401134 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -118,7 +118,7 @@ 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_ident id | Pexp_construct (id, _) | Pexp_field (_, id) @@ -184,7 +184,7 @@ let iterator = let loc = st.pstr_loc in match st.pstr_desc with | Pstr_type (_, []) -> empty_type loc - | Pstr_value (_, []) -> empty_let loc + | Pstr_value (_, _, []) -> empty_let loc | _ -> () in let signature_item self sg = diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 6c4b3fb5f29..adcbb6b956d 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -370,7 +370,7 @@ module M = struct match desc with | Pstr_eval (x, attrs) -> sub.attributes sub attrs; sub.expr sub x - | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_value (_m, _r, vbs) -> List.iter (sub.value_binding sub) vbs | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Pstr_typext te -> sub.type_extension sub te @@ -460,7 +460,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) -> diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index e909abc2aae..83e8f0664a3 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -433,7 +433,8 @@ module M = struct | Pstr_eval (x, attrs) -> let attrs = sub.attributes sub attrs in eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + (* jra: mutable flag should not be ignored *) + | Pstr_value (_, r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) @@ -529,7 +530,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) -> + (* jra: mutable flag should not be ignored here *) + | Pexp_let (_, r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) | Pexp_function (ps, c, b) -> diff --git a/parsing/depend.ml b/parsing/depend.ml index ad6a73af9b2..8d24df5855a 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -239,7 +239,8 @@ let rec add_expr bv exp = match exp.pexp_desc with Pexp_ident l -> add bv l | Pexp_constant _ -> () - | Pexp_let(rf, pel, e) -> + (* jra: mutable flag should not be ignored here *) + | Pexp_let(_, 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 @@ -637,7 +638,8 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t = match item.pstr_desc with Pstr_eval (e, _attrs) -> add_expr bv e; (bv, m) - | Pstr_value(rf, pel) -> + (* jra: mutable flag should not be ignored here *) + | Pstr_value(_, rf, pel) -> let bv = add_bindings rf bv pel in (bv, m) | Pstr_primitive vd -> add_type bv vd.pval_type; (bv, m) diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml index 691d24cd0fe..beb05869099 100644 --- a/parsing/language_extension.ml +++ b/parsing/language_extension.ml @@ -73,6 +73,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Labeled_tuples -> (module Unit) | Small_numbers -> (module Maturity) | Instances -> (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 @@ -85,8 +86,8 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = 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 -> - false + | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances | Let_mutable + -> false let maturity_of_unique_for_drf = Stable @@ -109,6 +110,7 @@ module Exist_pair = struct | Pair (Labeled_tuples, ()) -> Stable | Pair (Small_numbers, m) -> m | Pair (Instances, ()) -> Stable + | Pair (Let_mutable, ()) -> Beta let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext @@ -122,7 +124,7 @@ module Exist_pair = struct | Pair ( (( Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening | Labeled_tuples - | Instances | Overwriting ) as ext), + | Instances | Overwriting | Let_mutable) as ext), _ ) -> to_string ext @@ -153,6 +155,7 @@ module Exist_pair = struct | "small_numbers" -> Some (Pair (Small_numbers, Stable)) | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | "instances" -> Some (Pair (Instances, ())) + | "let_mutable" -> Some (Pair (Let_mutable, ())) | _ -> None end @@ -212,9 +215,10 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = | Labeled_tuples, Labeled_tuples -> Some Refl | Small_numbers, Small_numbers -> Some Refl | Instances, Instances -> 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 ), + | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances | Let_mutable), _ ) -> None diff --git a/parsing/language_extension.mli b/parsing/language_extension.mli index 5ce88e276f2..201a023ab6e 100644 --- a/parsing/language_extension.mli +++ b/parsing/language_extension.mli @@ -31,6 +31,7 @@ type 'a t = 'a Language_extension_kernel.t = | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : 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/parser.mly b/parsing/parser.mly index cf0941671b5..5d375b75e47 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,7 +690,7 @@ 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 + let str = mkstr ~loc (Pstr_value(lbs.lbs_mutable, lbs.lbs_rec, List.rev bindings)) in match lbs.lbs_extension with | None -> str | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), [])) @@ -703,7 +704,7 @@ 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)) + 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 = @@ -3230,12 +3231,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 1e990f50f2e..cbc4f181384 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -364,7 +364,8 @@ 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 of mutable_flag * rec_flag * value_binding list * expression + (* jra: need to update this documentation *) (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - [let P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, @@ -1231,7 +1232,8 @@ and structure_item = and structure_item_desc = | Pstr_eval of expression * attributes (** [E] *) - | Pstr_value of rec_flag * value_binding list + | Pstr_value of mutable_flag * rec_flag * value_binding list + (* jra: update this documentation *) (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: - [let P1 = E1 and ... and Pn = EN] when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 93cd6ed69b7..79ce6d0a8e5 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -993,12 +993,14 @@ 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 *) + (* jra: what? *) 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 []) }, @@ -1410,7 +1412,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) (* jra: don't hard-code Immutable *) (class_expr ctxt) ce | Pcl_apply (ce, l) -> pp f "((%a)@ %a)" (* Cf: #7200 *) @@ -1816,7 +1818,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) = +(* jra: don't ignore mutable flag *) +and bindings ctxt f (_,rf,l) = let binding kwd rf f x = (* The other modes are printed inside [binding] *) let legacy, x = @@ -1856,9 +1859,9 @@ and structure_item ctxt f x = (item_attributes ctxt) attrs | Pstr_type (_, []) -> assert false | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) - | Pstr_value (rf, l) -> + | Pstr_value (mf, 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) (mf,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 a00b64d3287..ef98ff94c11 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -308,8 +308,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) -> @@ -1019,8 +1019,8 @@ and structure_item i ppf x = line i ppf "Pstr_eval\n"; attributes i ppf attrs; expression i ppf e; - | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + | Pstr_value (mf, rf, l) -> + line i ppf "Pstr_value %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; | Pstr_primitive vd -> line i ppf "Pstr_primitive\n"; diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index 3c9ffeeda9d..d07adc9ef72 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -332,8 +332,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) -> @@ -1069,8 +1069,8 @@ and structure_item i ppf x = line i ppf "Pstr_eval\n"; attributes i ppf attrs; expression i ppf e; - | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + | Pstr_value (mf, rf, l) -> + line i ppf "Pstr_value %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; | Pstr_primitive vd -> line i ppf "Pstr_primitive\n"; diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml new file mode 100644 index 00000000000..3d00716a215 --- /dev/null +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -0,0 +1,269 @@ +(* TEST + flags = "-extension let_mutable"; + expect; *) + +(* Test 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 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: The variable x is mutable, so cannot be used inside a closure that might escape +|}] + +(* 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: The variable x is mutable, so cannot be used inside a closure that might escape +|}] + +(* 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 local_ + 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: The variable x is mutable, so cannot be used inside a closure that might escape +|}] + + +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 localk 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 +|}] + +(* 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 local_ + 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 local_ + 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 local_ 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 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 left-hand side of `let mutable' +|}] + +(* Test 9: disallowed at the structure level *) +let mutable foo_9_1 = 10 +[%%expect{| +Line 1, characters 12-19: +1 | let mutable foo_9_1 = 10 + ^^^^^^^ +Error: Mutable let bindings are not allowed at the structure level +|}] + +module M9 = struct + let mutable foo_9_2 = 20 +end +[%%expect{| +Line 2, characters 14-21: +2 | let mutable foo_9_2 = 20 + ^^^^^^^ +Error: Mutable let bindings are not allowed at the structure level +|}] + +(* Test 10: disallowed in class definitions *) +class c10 = + let mutable x = 20 in + object + method read_incr = + x <- x + 1; + x + end + +[%%expect{| +Line 2, characters 14-15: +2 | let mutable x = 20 in + ^ +Error: Mutable let bindings are not allowed inside class definition +|}] + +(* 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 = +|}] diff --git a/typing/typecore.ml b/typing/typecore.ml index bd421c202bd..c65f6900130 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4506,7 +4506,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 @@ -5749,7 +5749,8 @@ and type_expect_ exp_type = type_constant cst; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_let(Nonrecursive, + (* jra: do not ignore mutable flag *) + | Pexp_let(_, Nonrecursive, [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) when turn_let_into_match spat -> (* TODO: allow non-empty attributes? *) @@ -5758,7 +5759,7 @@ 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) -> + | Pexp_let(_, rec_flag, spat_sexp_list, sbody) -> let existential_context = if rec_flag = Recursive then In_rec else if List.compare_length_with spat_sexp_list 1 > 0 then In_group diff --git a/typing/typemod.ml b/typing/typemod.ml index 741d198ca98..414fa063643 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3098,7 +3098,8 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = raise (Error (sexpr.pexp_loc, env, Toplevel_unnamed_nonvalue sort)) end; Tstr_eval (expr, sort, attrs), [], shape_map, env - | Pstr_value (rec_flag, sdefs) -> + (* jra: mutable flag should not be ignored *) + | Pstr_value (_, rec_flag, sdefs) -> let (defs, newenv) = Typecore.type_binding env rec_flag ~force_toplevel sdefs in let defs = match rec_flag with diff --git a/typing/untypeast.ml b/typing/untypeast.ml index cf5c974118d..ee23f329cf1 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -172,7 +172,8 @@ let structure_item sub item = match item.str_desc with Tstr_eval (exp, _, attrs) -> Pstr_eval (sub.expr sub exp, attrs) | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + (* jra: don't hard-code Immutable *) + Pstr_value (Immutable, rec_flag, List.map (sub.value_binding sub) list) | Tstr_primitive vd -> Pstr_primitive (sub.value_description sub vd) | Tstr_type (rec_flag, list) -> @@ -494,7 +495,8 @@ 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, + (* jra: Immutable should not be hard-coded *) + Pexp_let (Immutable, rec_flag, List.map (sub.value_binding sub) list, sub.expr sub exp) | Texp_function { params; body } -> diff --git a/utils/language_extension_kernel.ml b/utils/language_extension_kernel.ml index 7e8ac8dadce..748606847bc 100644 --- a/utils/language_extension_kernel.ml +++ b/utils/language_extension_kernel.ml @@ -18,6 +18,7 @@ type _ t = | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : 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 @@ -34,3 +35,4 @@ let to_string : type a. a t -> string = function | Labeled_tuples -> "labeled_tuples" | Small_numbers -> "small_numbers" | Instances -> "instances" + | Let_mutable -> "let_mutable" diff --git a/utils/language_extension_kernel.mli b/utils/language_extension_kernel.mli index 1fdd1c17b02..9f6ffda4158 100644 --- a/utils/language_extension_kernel.mli +++ b/utils/language_extension_kernel.mli @@ -29,6 +29,7 @@ type _ t = | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : 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 e590a2c4cc9..c82220f86cf 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 -> + | Instances | Overwriting | Let_mutable -> let error_msg = Format.sprintf "No counters supported for language extension : %s." (Language_extension_kernel.to_string lang_ext) From bfd44d9e98349484234ca57f089ccc55b16d0691 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Thu, 1 May 2025 18:08:13 -0400 Subject: [PATCH 2/8] It works --- file_formats/cmt_format.ml | 8 +- lambda/matching.ml | 9 +- lambda/matching.mli | 2 +- lambda/transl_array_comprehension.ml | 2 +- lambda/transl_list_comprehension.ml | 2 +- lambda/translcore.ml | 16 +- ocamldoc/odoc_ast.ml | 3 +- parsing/ast_helper.ml | 6 +- parsing/ast_helper.mli | 2 +- parsing/ast_invariants.ml | 2 +- parsing/ast_iterator.ml | 2 +- parsing/ast_mapper.ml | 8 +- parsing/depend.ml | 6 +- parsing/language_extension.ml | 3 +- parsing/parser.mly | 6 +- parsing/parsetree.mli | 19 +- parsing/pprintast.ml | 20 +- parsing/printast.ml | 4 +- printer/printast_with_mappings.ml | 4 +- testsuite/tests/messages/spellcheck.ml | 2 +- .../locations_test.compilers.reference | 4 +- .../parsing/extensions.compilers.reference | 2 +- .../shortcut_ext_attr.compilers.reference | 2 +- .../tests/typing-local/alloc.heap.reference | 1 + testsuite/tests/typing-local/alloc.ml | 11 +- .../tests/typing-local/alloc.stack.reference | 1 + .../tests/typing-misc/typecore_errors.ml | 4 +- typing/env.ml | 71 ++++-- typing/env.mli | 14 +- typing/jkind.ml | 4 + typing/jkind_intf.ml | 3 + typing/jkind_types.ml | 2 + typing/printtyped.ml | 8 + typing/tast_iterator.ml | 7 + typing/tast_mapper.ml | 5 + typing/typeclass.ml | 3 +- typing/typecore.ml | 220 +++++++++++++----- typing/typecore.mli | 15 +- typing/typedtree.ml | 3 + typing/typedtree.mli | 4 + typing/typemod.ml | 6 +- typing/types.ml | 1 + typing/types.mli | 1 + typing/uniqueness_analysis.ml | 9 + typing/untypeast.ml | 15 +- typing/value_rec_check.ml | 24 ++ 46 files changed, 409 insertions(+), 157 deletions(-) diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index 89b7638721e..f7ad98e9d44 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/lambda/matching.ml b/lambda/matching.ml index 8ca101b7242..15d65630400 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -4245,7 +4245,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 mutability pat body = match pat.pat_desc with | Tpat_any -> (* This eliminates a useless variable (and stack slot in bytecode) @@ -4261,7 +4261,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, param, body) + begin match mutability with + | Asttypes.Mutable -> Lmutlet (k, id, param, body) + | Asttypes.Immutable -> Llet (Strict, k, id, param, body) + end | _ -> let opt = ref false in let nraise = next_raise_count () in @@ -4480,7 +4483,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 924bd6a0f9f..01a97574a93 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -502,7 +502,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 b5989eb6092..c1b2127e1bf 100644 --- a/lambda/transl_list_comprehension.ml +++ b/lambda/transl_list_comprehension.ml @@ -198,7 +198,7 @@ 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 00cdb6ffa4a..b2daaac6618 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 @@ -948,11 +952,14 @@ 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 (* jra: is this right? *) | 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) -> + Lassign(id.txt, transl_exp ~scopes Jkind.Sort.Const.for_mutable_var 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 @@ -1856,7 +1863,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 -> @@ -1880,6 +1887,13 @@ 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} body = + let lam = transl_bound_exp ~scopes ~in_structure:false pat Jkind.Sort.Const.for_mutable_var expr vb_loc attr in + let lam = Translattribute.add_function_attributes lam vb_loc attr in + Matching.for_let ~scopes ~return_layout ~arg_sort:Jkind.Sort.Const.for_mutable_var + 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/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 157bcf5adca..a5dfba13569 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1025,8 +1025,7 @@ module Analyser = | Parsetree.Pstr_attribute _ | Parsetree.Pstr_extension _ -> (0, env, []) - (* jra: mutable flag should not be ignored *) - | Parsetree.Pstr_value (_, rec_flag, pat_exp_list) -> + | Parsetree.Pstr_value (rec_flag, pat_exp_list) -> (* of rec_flag * (pattern * expression) list *) (* For each value, look for the value name, then look in the typedtree for the corresponding information, diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index bb4ed69e83b..511931bf3d3 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -209,8 +209,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) - (* jra: Immutable should not be hard-coded *) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (Immutable, 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)) @@ -339,8 +338,7 @@ module Str = struct let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - (* jra: Immutable should not be hard-coded *) - let value ?loc a b = mk ?loc (Pstr_value (Immutable, a, b)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) let primitive ?loc a = mk ?loc (Pstr_primitive a) let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) let type_extension ?loc a = mk ?loc (Pstr_typext a) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 1b6a642053e..e05d067cfdf 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -149,7 +149,7 @@ 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 + 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 diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 42b38401134..8108a81efd8 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -184,7 +184,7 @@ let iterator = let loc = st.pstr_loc in match st.pstr_desc with | Pstr_type (_, []) -> empty_type loc - | Pstr_value (_, _, []) -> empty_let loc + | Pstr_value (_, []) -> empty_let loc | _ -> () in let signature_item self sg = diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index adcbb6b956d..0b2237c9a6e 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -370,7 +370,7 @@ module M = struct match desc with | Pstr_eval (x, attrs) -> sub.attributes sub attrs; sub.expr sub x - | Pstr_value (_m, _r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Pstr_typext te -> sub.type_extension sub te diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 83e8f0664a3..f491470bb40 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -433,8 +433,7 @@ module M = struct | Pstr_eval (x, attrs) -> let attrs = sub.attributes sub attrs in eval ~loc ~attrs (sub.expr sub x) - (* jra: mutable flag should not be ignored *) - | Pstr_value (_, r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) @@ -530,9 +529,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) - (* jra: mutable flag should not be ignored here *) - | 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 diff --git a/parsing/depend.ml b/parsing/depend.ml index 8d24df5855a..e995c63d5a2 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -239,8 +239,7 @@ let rec add_expr bv exp = match exp.pexp_desc with Pexp_ident l -> add bv l | Pexp_constant _ -> () - (* jra: mutable flag should not be ignored here *) - | 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 @@ -638,8 +637,7 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t = match item.pstr_desc with Pstr_eval (e, _attrs) -> add_expr bv e; (bv, m) - (* jra: mutable flag should not be ignored here *) - | Pstr_value(_, rf, pel) -> + | Pstr_value(rf, pel) -> let bv = add_bindings rf bv pel in (bv, m) | Pstr_primitive vd -> add_type bv vd.pval_type; (bv, m) diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml index beb05869099..d790e7f3d31 100644 --- a/parsing/language_extension.ml +++ b/parsing/language_extension.ml @@ -176,7 +176,8 @@ let all_extensions = Pack SIMD; Pack Labeled_tuples; Pack Small_numbers; - Pack Instances ] + Pack Instances; + Pack Let_mutable ] (**********************************) (* string conversions *) diff --git a/parsing/parser.mly b/parsing/parser.mly index 5d375b75e47..9ec1d6cd11a 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -690,7 +690,9 @@ 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_mutable, lbs.lbs_rec, List.rev bindings)) in + if lbs.lbs_mutable = Mutable + then not_expecting loc "mutable"; (* jra: is this the best way to do this? *) + 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]), [])) @@ -716,6 +718,8 @@ let class_of_let_bindings ~loc lbs body = ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in + if lbs.lbs_mutable = Mutable + then not_expecting loc "mutable"; (* jra: is this the best way to do this? *) (* 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)) diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index cbc4f181384..4562d4dfd26 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -365,12 +365,19 @@ and expression_desc = (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) | Pexp_let of mutable_flag * rec_flag * value_binding list * expression - (* jra: need to update this documentation *) - (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + (** [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 and ... and Pn = EN in E] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]} + and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + - [let mutable rec P1 = E1 and ... and Pn = EN in E] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]} + and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}. *) | Pexp_function of function_param list * function_constraint * function_body @@ -469,6 +476,7 @@ and expression_desc = *) | Pexp_send of expression * label loc (** [E # m] *) | Pexp_new of Longident.t loc (** [new M.c] *) + (* jra: should this be renamed? Both mutable vars and instance vars use this syntax *) | Pexp_setinstvar of label loc * expression (** [x <- 2] *) | Pexp_override of (label loc * expression) list (** [{< x1 = E1; ...; xn = En >}] *) @@ -1232,8 +1240,7 @@ and structure_item = and structure_item_desc = | Pstr_eval of expression * attributes (** [E] *) - | Pstr_value of mutable_flag * rec_flag * value_binding list - (* jra: update this documentation *) + | Pstr_value of rec_flag * value_binding list (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: - [let P1 = E1 and ... and Pn = EN] when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 79ce6d0a8e5..9d641f7c025 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -998,7 +998,6 @@ and expression ctxt f x = (*no indentation here, a new line*) *) (* rec_flag rf *) (* mutable_flag mf *) - (* jra: what? *) pp f "@[<2>%a in@;<1 -2>%a@]" (bindings reset_ctxt) (mf,rf,l) (expression ctxt) e @@ -1412,7 +1411,7 @@ and class_expr ctxt f x = (class_expr ctxt) e | Pcl_let (rf, l, ce) -> pp f "%a@ in@ %a" - (bindings ctxt) (Immutable,rf,l) (* jra: don't hard-code Immutable *) + (bindings ctxt) (Immutable,rf,l) (class_expr ctxt) ce | Pcl_apply (ce, l) -> pp f "((%a)@ %a)" (* Cf: #7200 *) @@ -1818,9 +1817,8 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; pvb_modes = mode end (* [in] is not printed *) -(* jra: don't ignore mutable flag *) -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 @@ -1828,18 +1826,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 @@ -1859,9 +1857,9 @@ and structure_item ctxt f x = (item_attributes ctxt) attrs | Pstr_type (_, []) -> assert false | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) - | Pstr_value (mf, rf, l) -> + | Pstr_value (rf, l) -> (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (mf,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 ef98ff94c11..acf22a21bb2 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -1019,8 +1019,8 @@ and structure_item i ppf x = line i ppf "Pstr_eval\n"; attributes i ppf attrs; expression i ppf e; - | Pstr_value (mf, rf, l) -> - line i ppf "Pstr_value %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; list i value_binding ppf l; | Pstr_primitive vd -> line i ppf "Pstr_primitive\n"; diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index d07adc9ef72..0ac07471093 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -1069,8 +1069,8 @@ and structure_item i ppf x = line i ppf "Pstr_eval\n"; attributes i ppf attrs; expression i ppf e; - | Pstr_value (mf, rf, l) -> - line i ppf "Pstr_value %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; list i value_binding ppf l; | Pstr_primitive vd -> line i ppf "Pstr_primitive\n"; 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/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/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-local/alloc.heap.reference b/testsuite/tests/typing-local/alloc.heap.reference index 8a7449cbf7d..b893eee43d9 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 + letmutable: Allocation diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index 87cedc009e7..d74880eedaf 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 local_ + x <- 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..366440c192b 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 + letmutable: No Allocation 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/typing/env.ml b/typing/env.ml index 8461bfa1b30..b7c44327cf5 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -785,8 +785,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 +805,7 @@ type lookup_error = | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t | No_unboxed_version of Longident.t | Error_from_persistent_env of Persistent_env.error + | Mutable_value_used_in_closure of string type error = | Missing_module of Location.t * Path.t * Path.t @@ -3298,6 +3299,10 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty 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 (_, locks, Val_bound {vda_description={val_kind=Val_mut}}) + (* jra: Unclear if this handles locks correctly *) + when List.exists (function Closure_lock _ | Region_lock -> true | _ -> false) locks -> + may_lookup_error errors loc env (Mutable_value_used_in_closure name) | Ok (path, locks, Val_bound vda) -> use_value ~use ~loc path vda; path, locks, vda @@ -4031,27 +4036,46 @@ 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 + +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, Pident id -> + let rec mode_of_locks mode = function + | [] -> mode + | Closure_lock _ :: _ | Escape_lock _ :: _ -> + lookup_error loc env (Mutable_value_used_in_closure (Ident.name id)) + | Region_lock :: locks -> + mode_of_locks (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) locks + | _ :: locks -> mode_of_locks mode locks + in + let mode = mode_of_locks (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.local) locks in + use_value ~use ~loc path vda; + Mutable_variable (id, mode, Subst.Lazy.force_type_expr desc.val_type) + | 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 *) @@ -4348,11 +4372,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 = @@ -4504,13 +4528,13 @@ 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_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_instance_variables env s; + spellcheck_name ppf extract_settable_variables env s | Masked_instance_variable lid -> fprintf ppf "The instance variable %a@ \ @@ -4623,6 +4647,11 @@ let report_lookup_error _loc env ppf = function (Style.as_inline_code !print_longident) lid | Error_from_persistent_env err -> Persistent_env.report_error ppf err + | Mutable_value_used_in_closure name -> + fprintf ppf + "@[The variable %s is mutable, so cannot be used \ + inside a closure that might escape@]" + name let report_error ppf = function | Missing_module(_, path1, path2) -> diff --git a/typing/env.mli b/typing/env.mli index 507ce49d348..842054199c3 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -238,8 +238,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 +257,7 @@ type lookup_error = | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t | No_unboxed_version of Longident.t | Error_from_persistent_env of Persistent_env.error + | Mutable_value_used_in_closure of string (* jra: Maybe rename this error/add other errors? *) val lookup_error: Location.t -> t -> lookup_error -> 'a @@ -337,9 +338,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 + +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 5d3b5a51d28..91d9a147af7 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -2797,6 +2797,9 @@ module Format_history = struct fprintf ppf "it's the type of the first argument to a function in a recursive \ module" + | Mutable_value -> + fprintf ppf + "it's the type of a let mutable value" | Unknown s -> fprintf ppf "unknown @[(please alert the Jane Street@;\ @@ -3538,6 +3541,7 @@ module Debug_printers = struct | Class_term_argument -> fprintf ppf "Class_term_argument" | Debug_printer_argument -> fprintf ppf "Debug_printer_argument" | Recmod_fun_arg -> fprintf ppf "Recmod_fun_arg" + | Mutable_value -> fprintf ppf "Mutable_value" | Unknown s -> fprintf ppf "Unknown %s" s let product_creation_reason ppf : History.product_creation_reason -> _ = diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index d22fdfb0fc3..b9a68f262a2 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -74,6 +74,8 @@ module type Sort = sig val for_instance_var : t + val for_mutable_var : t + val for_lazy_body : t val for_tuple_element : t @@ -297,6 +299,7 @@ module History = struct | Class_term_argument | Debug_printer_argument | Recmod_fun_arg + | Mutable_value | Unknown of string (* CR layouts: get rid of these *) type immediate_creation_reason = diff --git a/typing/jkind_types.ml b/typing/jkind_types.ml index 0326906b831..84a588b0ff3 100644 --- a/typing/jkind_types.ml +++ b/typing/jkind_types.ml @@ -138,6 +138,8 @@ module Sort = struct let for_instance_var = value + let for_mutable_var = value + let for_class_arg = value let for_method = value diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 0a540df111e..670653aa812 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -489,11 +489,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; @@ -613,6 +618,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 1f183c0275b..26490a8236d 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 a6b9f01fa37..8199157481a 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -458,6 +458,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 @@ -569,6 +571,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, @@ -576,6 +579,8 @@ let expr sub x = map_loc sub id, sub.expr sub exp ) + | Texp_setmutvar (id, exp) -> + Texp_setmutvar (map_loc sub id, sub.expr sub exp) | Texp_override (path, list) -> Texp_override ( path, diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 91b80e52d08..e1c555b9d75 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1434,7 +1434,8 @@ 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 + (* jra: should this be hard-coded? *) + 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 c65f6900130..c0af454953c 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 @@ -1151,6 +1157,8 @@ type pattern_variable = pv_id: Ident.t; pv_uid: Uid.t; pv_mode: Value.l; + (* jra: I don't fully understand the difference between mutable_flag and mutability *) + pv_mutable: mutable_flag; pv_type: type_expr; pv_loc: Location.t; pv_as_var: bool; @@ -1247,13 +1255,24 @@ 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 -> + (* jra: should this be modified? *) + (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 + 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 +1320,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 +1354,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 +1974,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 } + (* jra: is this right? See add_pattern_variables# *) in (pv_id, pv_uid), add_pattern_variables ~check ~check_as:check env [pv]) @@ -1975,9 +1997,29 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = pv_loc name pv_mode + Immutable (* jr: is this right? *) pv_type pv_attributes) +let value_bindings_mutability (mutable_flag : mutable_flag) env ?restriction vbs = + match vbs, mutable_flag with + | vb :: vbs, Mutable -> begin + let loc = vb.pvb_pat.ppat_loc in + (* If mutable attribute is present, check: + - Let_mutable is enabled + - There is only one value binding + - Mutables are not restricted here + - The pattern has the allowed shape *) + 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 +2649,24 @@ 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 +2856,7 @@ 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 +2882,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,7 +2898,7 @@ 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 + 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); @@ -3140,14 +3184,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 +3202,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 +3213,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 +3235,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 +3298,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 +4225,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 +4321,9 @@ let rec is_nonexpansive exp = | Texp_for _ | Texp_send _ | Texp_instvar _ + | Texp_mutvar _ | Texp_setinstvar _ + | Texp_setmutvar _ | Texp_override _ | Texp_letexception _ | Texp_letop _ @@ -4724,12 +4776,12 @@ let check_partial_application ~statement exp = | Texp_overwrite _ | Texp_hole _ | Texp_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ - | Texp_while _ | Texp_for _ | Texp_instvar _ - | Texp_setinstvar _ | Texp_override _ | Texp_assert _ - | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable - | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) - | Texp_probe _ | Texp_probe_is_enabled _ | Texp_src_pos - | Texp_function _ -> + | Texp_while _ | Texp_for _ | Texp_instvar _ | Texp_mutvar _ + | Texp_setinstvar _ | Texp_setmutvar _ | Texp_override _ + | Texp_assert _ | Texp_lazy _ | Texp_object _ | Texp_pack _ + | Texp_unreachable | Texp_extension_constructor _ + | Texp_ifthenelse (_, _, None) | Texp_probe _ + | Texp_probe_is_enabled _ | Texp_src_pos | Texp_function _ -> check_statement () | Texp_match (_, _, cases, _) -> List.iter (fun {c_rhs; _} -> check c_rhs) cases @@ -4737,8 +4789,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_letexception (_, e) | Texp_letmodule (_, _, _, _, e) + | Texp_let (_, _, e) | Texp_letmutable(_, e) | Texp_sequence (_, _, e) + | Texp_open (_, e) | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) | Texp_exclave e -> check e | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ -> @@ -5692,6 +5744,11 @@ 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 -> Texp_mutvar {loc = lid.loc; txt = id} + | _ -> assert false + end | Val_self (_, _, _, cl_num) -> let (path, _) = Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env @@ -5749,7 +5806,6 @@ and type_expect_ exp_type = type_constant cst; exp_attributes = sexp.pexp_attributes; exp_env = env } - (* jra: do not ignore mutable flag *) | Pexp_let(_, Nonrecursive, [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) when turn_let_into_match spat -> @@ -5759,8 +5815,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 + value_bindings_mutability 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,7 +5844,7 @@ and type_expect_ else Modules_rejected in let (pat_exp_list, new_env) = - type_let existential_context env rec_flag spat_sexp_list + type_let existential_context env mutable_flag rec_flag spat_sexp_list allow_modules in let body = @@ -5827,8 +5888,15 @@ 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, _ -> fatal_error "Typecore.type_expect" + (* Unreachable: should be prevented by [value_bindings_mutability] *) + 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; @@ -6412,28 +6480,35 @@ 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_setinstvar (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_default (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global)) + 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) -> + let newval = + type_expect env (mode_default mode) + snewval (mk_expected (instance ty)) + in + let lid = {txt = id; loc} in + Texp_setmutvar(lid, 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 _ = @@ -9085,7 +9160,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 mut_flag rec_flag spat_sexp_list allow_modules = let rec sexp_is_fun sexp = match sexp.pexp_desc with | Pexp_function _ -> true @@ -9126,7 +9201,7 @@ 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 + type_pattern_list Value mut_flag existential_context env spatl nvs allow_modules ) ~post:(fun (_, _, _, pvs, _) -> iter_pattern_variables_type generalize pvs) @@ -9250,7 +9325,11 @@ 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 + (* CR-someday let_mutable: jkind should be sort *) + ~f_immut:generalize + ~f_mut:(unify_var env (newvar (Jkind.Builtin.value ~why:Mutable_value))) + pvs; (* update pattern variable jkind reasons *) List.iter (fun pv -> @@ -9938,6 +10017,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 @@ -10042,21 +10122,21 @@ 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) @@ -10789,6 +10869,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.@]" @@ -10872,6 +10962,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 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" diff --git a/typing/typecore.mli b/typing/typecore.mli index 1a9fe0465f2..5b6f086ea03 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: @@ -162,6 +167,10 @@ val generalize_structure_exp: Typedtree.expression -> unit val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit +val value_bindings_mutability : + mutable_flag -> Env.t -> ?restriction:mutable_restriction -> + Parsetree.value_binding list -> unit + val reset_allocations: unit -> unit val optimise_allocations: unit -> unit @@ -267,6 +276,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 @@ -289,6 +299,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 diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 8617ae35545..65fe9546b81 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; @@ -276,7 +277,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 * 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 a876a249981..9ca253e615c 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; @@ -480,7 +482,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 * 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 414fa063643..20f8c7a88d9 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3098,10 +3098,10 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = raise (Error (sexpr.pexp_loc, env, Toplevel_unnamed_nonvalue sort)) end; Tstr_eval (expr, sort, attrs), [], shape_map, env - (* jra: mutable flag should not be ignored *) - | Pstr_value (_, rec_flag, sdefs) -> + | Pstr_value (rec_flag, sdefs) -> let (defs, newenv) = - Typecore.type_binding env rec_flag ~force_toplevel sdefs in + (* jra: should this be hard-coded? *) + 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/types.ml b/typing/types.ml index 54cc61b6d18..1e005f8a652 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -445,6 +445,7 @@ module Vars = Misc.Stdlib.String.Map type value_kind = Val_reg (* Regular value *) + | Val_mut (* Mutable value (let mutable x = ...) *) | 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 4870d21647a..9ede95f0bc4 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -584,6 +584,7 @@ module Vars : Map.S with type key = string type value_kind = Val_reg (* Regular value *) + | Val_mut (* Mutable value (let mutable x = ...) *) | 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 cfa37cce07c..3bb0f5ccb61 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -2144,6 +2144,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) -> + (* jra: 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 @@ -2331,7 +2338,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 ee23f329cf1..7a84dfa6c2c 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -172,8 +172,7 @@ let structure_item sub item = match item.str_desc with Tstr_eval (exp, _, attrs) -> Pstr_eval (sub.expr sub exp, attrs) | Tstr_value (rec_flag, list) -> - (* jra: don't hard-code Immutable *) - Pstr_value (Immutable, rec_flag, List.map (sub.value_binding sub) list) + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) | Tstr_primitive vd -> Pstr_primitive (sub.value_description sub vd) | Tstr_type (rec_flag, list) -> @@ -495,10 +494,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) -> - (* jra: Immutable should not be hard-coded *) 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 @@ -635,8 +637,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) + | Texp_setmutvar(lid, exp) -> + let lid = {loc = sub.location sub lid.loc; + txt = Ident.name lid.txt} in + Pexp_setinstvar (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 d7c7c97ba1c..f43abe7e258 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, _)], _, _, _) @@ -884,6 +901,13 @@ let rec expression : Typedtree.expression -> term_judg = path pth << Dereference; expression e << Dereference; ] + | Texp_setmutvar (_id,e) -> + (* + G |- e: m[Dereference] + ---------------------- + G |- x <- e: m + *) + expression e << Dereference | Texp_letexception ({ext_id}, e) -> (* G |- e: m ---------------------------- From 821925ed933f160eab55a0cc4dd286d4400f5ec0 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Fri, 2 May 2025 14:46:54 -0400 Subject: [PATCH 3/8] Make `let mutable` a syntax error in some cases --- lambda/matching.ml | 4 +- parsing/parse.ml | 6 +++ parsing/parser.mly | 6 ++- parsing/syntaxerr.ml | 4 ++ parsing/syntaxerr.mli | 2 + ...et_mutable_at_toplevel.compilers.reference | 7 +++ .../parse-errors/let_mutable_at_toplevel.ml | 8 ++++ .../let_mutable_in_class.compilers.reference | 11 +++++ .../parse-errors/let_mutable_in_class.ml | 14 ++++++ .../let_mutable_in_module.compilers.reference | 7 +++ .../parse-errors/let_mutable_in_module.ml | 10 +++++ .../tests/typing-local/alloc.heap.reference | 2 +- testsuite/tests/typing-local/alloc.ml | 4 +- .../tests/typing-local/alloc.stack.reference | 2 +- testsuite/tests/typing-local/let_mutable.ml | 45 +++---------------- typing/env.ml | 10 +++-- 16 files changed, 90 insertions(+), 52 deletions(-) create mode 100644 testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference create mode 100644 testsuite/tests/parse-errors/let_mutable_at_toplevel.ml create mode 100644 testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference create mode 100644 testsuite/tests/parse-errors/let_mutable_in_class.ml create mode 100644 testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference create mode 100644 testsuite/tests/parse-errors/let_mutable_in_module.ml diff --git a/lambda/matching.ml b/lambda/matching.ml index 15d65630400..2e78a598253 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -4245,7 +4245,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 mutability 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) @@ -4261,7 +4261,7 @@ let for_let ~scopes ~arg_sort ~return_layout loc param mutability 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 - begin match mutability with + begin match mutable_flag with | Asttypes.Mutable -> Lmutlet (k, id, param, body) | Asttypes.Immutable -> Llet (Strict, k, id, param, body) end diff --git a/parsing/parse.ml b/parsing/parse.ml index 1b3f6da349a..4d8e74a5e88 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -178,6 +178,12 @@ 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 () = Location.register_error_of_exn diff --git a/parsing/parser.mly b/parsing/parser.mly index 9ec1d6cd11a..29b9fe9fa3e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -691,7 +691,8 @@ let val_of_let_bindings ~loc lbs = lbs.lbs_bindings in if lbs.lbs_mutable = Mutable - then not_expecting loc "mutable"; (* jra: is this the best way to do this? *) + then raise (Syntaxerr.Error + (Syntaxerr.Let_mutable_not_allowed_at_structure_level (make_loc loc))); let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in match lbs.lbs_extension with | None -> str @@ -719,7 +720,8 @@ let class_of_let_bindings ~loc lbs body = lbs.lbs_bindings in if lbs.lbs_mutable = Mutable - then not_expecting loc "mutable"; (* jra: is this the best way to do this? *) + then raise (Syntaxerr.Error + (Syntaxerr.Let_mutable_not_allowed_in_class_definition (make_loc loc))); (* 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)) diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index c1dbac71d7b..9bf41849c53 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -35,6 +35,8 @@ 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 exception Error of error exception Escape_error @@ -51,6 +53,8 @@ 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 ill_formed_ast loc s = diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 47f2910fd0e..77b94d36a10 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -40,6 +40,8 @@ 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 exception Error of error exception Escape_error 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..94b2aef0df6 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference @@ -0,0 +1,7 @@ + + +Line 4, characters 0-18: +4 | 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..969552c0b94 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml @@ -0,0 +1,8 @@ +(* TEST_BELOW *) + +(* let mutable not allowed at structure level *) +let mutable x = 10 + +(* TEST + flags = "-extension let_mutable"; + toplevel; *) 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..0568f2e30c6 --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference @@ -0,0 +1,11 @@ + + +Lines 5-10, characters 2-5: + 5 | ..let mutable x = 20 in + 6 | object + 7 | method read_incr = + 8 | x <- x + 1; + 9 | x +10 | 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..38668f329fe --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_class.ml @@ -0,0 +1,14 @@ +(* TEST_BELOW *) + +(* let mutable is not allowed in class definitions *) +class c = + let mutable x = 20 in + object + method read_incr = + x <- x + 1; + x + end + +(* TEST + flags = "-extension let_mutable"; + toplevel; *) 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..7ed6b48c65d --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference @@ -0,0 +1,7 @@ + + +Line 5, characters 2-20: +5 | 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..9944904908e --- /dev/null +++ b/testsuite/tests/parse-errors/let_mutable_in_module.ml @@ -0,0 +1,10 @@ +(* TEST_BELOW *) + +(* let mutable not allowed at structure level *) +module M = struct + let mutable x = 20 +end + +(* TEST + flags = "-extension let_mutable"; + toplevel; *) diff --git a/testsuite/tests/typing-local/alloc.heap.reference b/testsuite/tests/typing-local/alloc.heap.reference index b893eee43d9..e4827df2031 100644 --- a/testsuite/tests/typing-local/alloc.heap.reference +++ b/testsuite/tests/typing-local/alloc.heap.reference @@ -36,4 +36,4 @@ optionaleta: Allocation object: Allocation object_direct: Allocation - letmutable: Allocation + let_mutable: Allocation diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index d74880eedaf..30d59ee2568 100644 --- a/testsuite/tests/typing-local/alloc.ml +++ b/testsuite/tests/typing-local/alloc.ml @@ -473,8 +473,8 @@ let obj_direct () = let let_mutable_loop () = let mutable x = [] in - for i = 0 to 10 do local_ - x <- i :: x + for i = 0 to 10 do exclave_ + x <- stack_ (i :: x) done; ignore_local x diff --git a/testsuite/tests/typing-local/alloc.stack.reference b/testsuite/tests/typing-local/alloc.stack.reference index 366440c192b..998fd416a87 100644 --- a/testsuite/tests/typing-local/alloc.stack.reference +++ b/testsuite/tests/typing-local/alloc.stack.reference @@ -36,4 +36,4 @@ optionaleta: No Allocation object: Allocation object_direct: Allocation - letmutable: No Allocation + let_mutable: No Allocation diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml index 3d00716a215..b77749892fc 100644 --- a/testsuite/tests/typing-local/let_mutable.ml +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -66,7 +66,7 @@ let foo4_1 y = Line 4, characters 9-24: 4 | x <- local_ (i :: x) ^^^^^^^^^^^^^^^ -Error: This value escapes its region +Error: This value escapes its region. |}] @@ -102,7 +102,7 @@ let foo4_3 y = (* Can't sneak local out of non-local while loop body region *) Line 5, characters 9-26: 5 | x <- (local_ (x + !i)); ^^^^^^^^^^^^^^^^^ -Error: This value escapes its region +Error: This value escapes its region. |}] let foo4_4 y = (* Can't sneak localk out of non-local while cond region *) @@ -115,7 +115,7 @@ let foo4_4 y = (* Can't sneak localk out of non-local while cond region *) Line 3, characters 13-29: 3 | while x <- (local_ (x + 1)); x <= 100 do ^^^^^^^^^^^^^^^^ -Error: This value escapes its region +Error: This value escapes its region. |}] (* Test 5: Allowed interactions with locals. *) @@ -203,7 +203,7 @@ let foo_8_1 y = Line 2, characters 14-21: 2 | let mutable (x1,x2) = (y,y+1) in ^^^^^^^ -Error: Only variables are allowed as left-hand side of `let mutable' +Error: Only variables are allowed as left-hand side of "let mutable" |}] type t8_2 = {x_8_2 : int} @@ -218,42 +218,7 @@ 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 left-hand side of `let mutable' -|}] - -(* Test 9: disallowed at the structure level *) -let mutable foo_9_1 = 10 -[%%expect{| -Line 1, characters 12-19: -1 | let mutable foo_9_1 = 10 - ^^^^^^^ -Error: Mutable let bindings are not allowed at the structure level -|}] - -module M9 = struct - let mutable foo_9_2 = 20 -end -[%%expect{| -Line 2, characters 14-21: -2 | let mutable foo_9_2 = 20 - ^^^^^^^ -Error: Mutable let bindings are not allowed at the structure level -|}] - -(* Test 10: disallowed in class definitions *) -class c10 = - let mutable x = 20 in - object - method read_incr = - x <- x + 1; - x - end - -[%%expect{| -Line 2, characters 14-15: -2 | let mutable x = 20 in - ^ -Error: Mutable let bindings are not allowed inside class definition +Error: Only variables are allowed as left-hand side of "let mutable" |}] (* Test 11: binding a mutable variable shouldn't be simplified away *) diff --git a/typing/env.ml b/typing/env.ml index b7c44327cf5..a1b0853a061 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -3300,8 +3300,7 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty 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 (_, locks, Val_bound {vda_description={val_kind=Val_mut}}) - (* jra: Unclear if this handles locks correctly *) - when List.exists (function Closure_lock _ | Region_lock -> true | _ -> false) locks -> + when List.exists (function Closure_lock _ | Escape_lock _ -> true | _ -> false) locks -> may_lookup_error errors loc env (Mutable_value_used_in_closure name) | Ok (path, locks, Val_bound vda) -> use_value ~use ~loc path vda; @@ -4054,10 +4053,13 @@ let lookup_settable_variable ?(use=true) ~loc name env = | Closure_lock _ :: _ | Escape_lock _ :: _ -> lookup_error loc env (Mutable_value_used_in_closure (Ident.name id)) | Region_lock :: locks -> - mode_of_locks (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) locks + mode_of_locks + (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) locks + | Exclave_lock :: _ -> + mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks | _ :: locks -> mode_of_locks mode locks in - let mode = mode_of_locks (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.local) locks in + let mode = mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks in use_value ~use ~loc path vda; Mutable_variable (id, mode, Subst.Lazy.force_type_expr desc.val_type) | Val_mut, _ -> assert false From fc761c2d970785209d2f7d4b96d8579d947c2965 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Fri, 2 May 2025 16:21:02 -0400 Subject: [PATCH 4/8] Change [local_] to [exclave_] in test and an fix infinite loop --- testsuite/tests/typing-local/let_mutable.ml | 6 +++--- typing/env.ml | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml index b77749892fc..82b541318d3 100644 --- a/testsuite/tests/typing-local/let_mutable.ml +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -131,7 +131,7 @@ 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 local_ + for i = 1 to y do exclave_ x <- local_ (i :: x) done; match x with @@ -143,14 +143,14 @@ 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 local_ + 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 local_ x <- (local_ (x + 1)); x <= 100 do + while exclave_ x <- (local_ (x + 1)); x <= 100 do x <- x + x done; x diff --git a/typing/env.ml b/typing/env.ml index a1b0853a061..79d210acf96 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -4048,14 +4048,14 @@ let lookup_settable_variable ?(use=true) ~loc name env = use_value ~use ~loc path vda; Instance_variable (path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type) | Val_mut, Pident id -> - let rec mode_of_locks mode = function + let rec mode_of_locks mode = function (* jra: surely this is incorrect *) | [] -> mode | Closure_lock _ :: _ | Escape_lock _ :: _ -> lookup_error loc env (Mutable_value_used_in_closure (Ident.name id)) | Region_lock :: locks -> mode_of_locks (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) locks - | Exclave_lock :: _ -> + | Exclave_lock :: locks -> mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks | _ :: locks -> mode_of_locks mode locks in From d306842614450d6b00123c90ba0e3cabceaca163 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Fri, 2 May 2025 16:32:25 -0400 Subject: [PATCH 5/8] Add `let mutable` to `parsetree/source_jane_street.ml` --- testsuite/tests/parsetree/source_jane_street.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index b597aebd6ec..8e6911df5ec 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -1469,3 +1469,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 +|}] From 5fbcff19428076712c707426f9d9f1229508e56e Mon Sep 17 00:00:00 2001 From: James Rayman Date: Fri, 2 May 2025 16:37:35 -0400 Subject: [PATCH 6/8] Run `make check-fmt` --- lambda/transl_list_comprehension.ml | 3 ++- parsing/language_extension.ml | 10 ++++++---- typing/jkind.ml | 4 +--- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/lambda/transl_list_comprehension.ml b/lambda/transl_list_comprehension.ml index c1b2127e1bf..4ea9827bf29 100644 --- a/lambda/transl_list_comprehension.ml +++ b/lambda/transl_list_comprehension.ml @@ -198,7 +198,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) Immutable pattern + ~return_layout:layout_any_value pattern.pat_loc (Lvar element) + Immutable pattern } (** Translates a list comprehension binding diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml index d790e7f3d31..57f3d56280a 100644 --- a/parsing/language_extension.ml +++ b/parsing/language_extension.ml @@ -86,8 +86,9 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = 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 | Let_mutable - -> false + | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances + | Let_mutable -> + false let maturity_of_unique_for_drf = Stable @@ -124,7 +125,7 @@ module Exist_pair = struct | Pair ( (( Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening | Labeled_tuples - | Instances | Overwriting | Let_mutable) as ext), + | Instances | Overwriting | Let_mutable ) as ext), _ ) -> to_string ext @@ -219,7 +220,8 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = | 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 | Let_mutable), + | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances + | Let_mutable ), _ ) -> None diff --git a/typing/jkind.ml b/typing/jkind.ml index 91d9a147af7..9e4714a2cec 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -2797,9 +2797,7 @@ module Format_history = struct fprintf ppf "it's the type of the first argument to a function in a recursive \ module" - | Mutable_value -> - fprintf ppf - "it's the type of a let mutable value" + | Mutable_value -> fprintf ppf "it's the type of a let mutable value" | Unknown s -> fprintf ppf "unknown @[(please alert the Jane Street@;\ From 449509ff5533fb25eef464ed33139339c8f051ca Mon Sep 17 00:00:00 2001 From: James Rayman Date: Tue, 6 May 2025 17:37:32 -0400 Subject: [PATCH 7/8] Add some currently failing `let mutable` tests --- testsuite/tests/typing-local/let_mutable.ml | 58 ++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml index 82b541318d3..572e758f5a3 100644 --- a/testsuite/tests/typing-local/let_mutable.ml +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -105,7 +105,7 @@ Line 5, characters 9-26: Error: This value escapes its region. |}] -let foo4_4 y = (* Can't sneak localk out of non-local while cond 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 @@ -118,6 +118,39 @@ Line 3, characters 13-29: Error: This value escapes its region. |}] +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 @@ -232,3 +265,26 @@ 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: disallow modes? *) +let u_13 y = let x @ unique = y in x;; + +let f_13 y z = let mutable x @ unique = y in + x <- z; + u_13 x +;; +[%%expect{| +|}] From 27d20623145b16d25031a978de62435956f46ae9 Mon Sep 17 00:00:00 2001 From: James Rayman Date: Thu, 8 May 2025 16:57:08 -0400 Subject: [PATCH 8/8] Misc * Allow mutable variables to be of any layout * Add tests related to modes (not fully worked out) * Avoid lines of more than 80 chars --- lambda/translcore.ml | 18 +++-- parsing/ast_helper.ml | 2 +- parsing/ast_helper.mli | 4 +- parsing/ast_iterator.ml | 2 +- parsing/ast_mapper.ml | 2 +- parsing/depend.ml | 2 +- parsing/parse.ml | 6 +- parsing/parser.mly | 5 +- parsing/parsetree.mli | 7 +- parsing/pprintast.ml | 2 +- parsing/printast.ml | 4 +- printer/printast_with_mappings.ml | 4 +- testsuite/tests/typing-local/let_mutable.ml | 82 +++++++++++++++++++-- tools/eqparsetree.ml | 2 +- tools/ocamlprof.ml | 2 +- typing/env.ml | 22 ++++-- typing/env.mli | 3 +- typing/jkind.ml | 7 +- typing/jkind_intf.ml | 5 +- typing/jkind_types.ml | 2 - typing/printtyped.ml | 2 +- typing/tast_iterator.ml | 2 +- typing/tast_mapper.ml | 4 +- typing/typeclass.ml | 1 - typing/typecore.ml | 57 ++++++++------ typing/typedtree.ml | 2 +- typing/typedtree.mli | 2 +- typing/typemod.ml | 1 - typing/types.ml | 2 +- typing/types.mli | 2 +- typing/uniqueness_analysis.ml | 2 +- typing/untypeast.ml | 6 +- typing/value_rec_check.ml | 2 +- 33 files changed, 187 insertions(+), 81 deletions(-) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index b2daaac6618..08c8a81ca36 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -952,14 +952,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 (* jra: is this right? *) + | 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) -> - Lassign(id.txt, transl_exp ~scopes Jkind.Sort.Const.for_mutable_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 @@ -1888,11 +1889,14 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) 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} body = - let lam = transl_bound_exp ~scopes ~in_structure:false pat Jkind.Sort.Const.for_mutable_var expr vb_loc attr in + {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 let lam = Translattribute.add_function_attributes lam vb_loc attr in - Matching.for_let ~scopes ~return_layout ~arg_sort:Jkind.Sort.Const.for_mutable_var - pat.pat_loc lam Mutable pat body + 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 diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 511931bf3d3..c136ddcc3b1 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -233,7 +233,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 e05d067cfdf..39c638501e4 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -149,8 +149,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 -> mutable_flag -> 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_iterator.ml b/parsing/ast_iterator.ml index 0b2237c9a6e..4ea7f5cf44f 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -508,7 +508,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 f491470bb40..a42d9c7748b 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -583,7 +583,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 e995c63d5a2..171d1015c56 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -275,7 +275,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/parse.ml b/parsing/parse.ml index 4d8e74a5e88..4c06473ca06 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -180,10 +180,12 @@ let prepare_error err = "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" + "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" + "Syntax error: Mutable let bindings are not allowed \ + inside class definitions" let () = Location.register_error_of_exn diff --git a/parsing/parser.mly b/parsing/parser.mly index 29b9fe9fa3e..b8be8f51cec 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -707,7 +707,8 @@ 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_mutable, lbs.lbs_rec, List.rev bindings, body)) + 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 = @@ -2812,7 +2813,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}) diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 4562d4dfd26..67c4c4fd15a 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -476,8 +476,11 @@ and expression_desc = *) | Pexp_send of expression * label loc (** [E # m] *) | Pexp_new of Longident.t loc (** [new M.c] *) - (* jra: should this be renamed? Both mutable vars and instance vars use this syntax *) - | 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 9d641f7c025..171efeb1dc2 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1079,7 +1079,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) = diff --git a/parsing/printast.ml b/parsing/printast.ml index acf22a21bb2..9f315c1b2f6 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -398,8 +398,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/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index 0ac07471093..5c45a680b25 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -422,8 +422,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/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml index 572e758f5a3..f966026eb5a 100644 --- a/testsuite/tests/typing-local/let_mutable.ml +++ b/testsuite/tests/typing-local/let_mutable.ml @@ -1,5 +1,6 @@ (* TEST flags = "-extension let_mutable"; + include stdlib_upstream_compatible; expect; *) (* Test 1: basic usage in a for loop *) @@ -279,12 +280,83 @@ type t_12 = Foo_12 of int val y_12 : t_12 = Foo_12 42 |}] -(* Test 13: disallow modes? *) -let u_13 y = let x @ unique = y in x;; +(* Test 13: modes? *) +let reset_ref (x @ unique) = x := 0;; -let f_13 y z = let mutable x @ unique = y in - x <- z; - u_13 x +let x_13 = + let y = ref 3 in + let mutable x @ unique = { contents = 1 } in + x <- y; + reset_ref x; + !y ;; [%%expect{| |}] + +(* 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 = #1.0 in + for i = 1 to 10 do + r <- div r #2.0 + done; + to_float r +;; +[%%expect{| +val r_15 : float = 0.0009765625 +|}] + +(* 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/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 79d210acf96..0bc90fb16f9 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -3300,7 +3300,11 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty 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 (_, locks, Val_bound {vda_description={val_kind=Val_mut}}) - when List.exists (function Closure_lock _ | Escape_lock _ -> true | _ -> false) locks -> + (* jra: move when clause to separate function *) + (* jra: expand _ -> false *) + when List.exists + (function Closure_lock _ | Escape_lock _ -> true | _ -> false) + locks -> may_lookup_error errors loc env (Mutable_value_used_in_closure name) | Ok (path, locks, Val_bound vda) -> use_value ~use ~loc path vda; @@ -4046,20 +4050,25 @@ let lookup_settable_variable ?(use=true) ~loc name env = match desc.val_kind, path with | Val_ivar(mut, cl_num), _ -> use_value ~use ~loc path vda; - Instance_variable (path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type) + Instance_variable + (path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type) | Val_mut, Pident id -> - let rec mode_of_locks mode = function (* jra: surely this is incorrect *) + let rec mode_of_locks mode = function + (* jra: surely this is incorrect *) | [] -> mode | Closure_lock _ :: _ | Escape_lock _ :: _ -> lookup_error loc env (Mutable_value_used_in_closure (Ident.name id)) | Region_lock :: locks -> mode_of_locks - (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) locks + (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global) + locks | Exclave_lock :: locks -> mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks | _ :: locks -> mode_of_locks mode locks in - let mode = mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks in + let mode = + mode_of_locks (Mode.Value.disallow_left Mode.Value.max) locks + in use_value ~use ~loc path vda; Mutable_variable (id, mode, Subst.Lazy.force_type_expr desc.val_type) | Val_mut, _ -> assert false @@ -4531,7 +4540,8 @@ let report_lookup_error _loc env ppf = function (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_cltypes env lid | Unbound_settable_variable s -> - fprintf ppf "Unbound instance variable or mutable variable %a" Style.inline_code s; + fprintf ppf "Unbound instance variable or mutable variable %a" + Style.inline_code 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" diff --git a/typing/env.mli b/typing/env.mli index 842054199c3..5bd4c166fab 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -257,7 +257,8 @@ type lookup_error = | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t | No_unboxed_version of Longident.t | Error_from_persistent_env of Persistent_env.error - | Mutable_value_used_in_closure of string (* jra: Maybe rename this error/add other errors? *) + | Mutable_value_used_in_closure of string + (* jra: Maybe rename this error/add other errors? *) val lookup_error: Location.t -> t -> lookup_error -> 'a diff --git a/typing/jkind.ml b/typing/jkind.ml index 9e4714a2cec..11dba912450 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -2643,6 +2643,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 mutable variable type used in an assignment" let format_concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function @@ -2697,6 +2699,7 @@ module Format_history = struct | Inside_of_Tarrow -> fprintf ppf "argument or result of a function type" | Array_type_argument -> fprintf ppf "it's the type argument to the array type" + | Mutable_value -> fprintf ppf "it's the type of a let mutable value" let format_immediate_creation_reason ppf : History.immediate_creation_reason -> _ = function @@ -2797,7 +2800,6 @@ module Format_history = struct fprintf ppf "it's the type of the first argument to a function in a recursive \ module" - | Mutable_value -> fprintf ppf "it's the type of a let mutable value" | Unknown s -> fprintf ppf "unknown @[(please alert the Jane Street@;\ @@ -3439,6 +3441,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 @@ -3478,6 +3481,7 @@ module Debug_printers = struct | Type_expression_call -> fprintf ppf "Type_expression_call" | Inside_of_Tarrow -> fprintf ppf "Inside_of_Tarrow" | Array_type_argument -> fprintf ppf "Array_type_argument" + | Mutable_value -> fprintf ppf "Mutable_value" let immediate_creation_reason ppf : History.immediate_creation_reason -> _ = function @@ -3539,7 +3543,6 @@ module Debug_printers = struct | Class_term_argument -> fprintf ppf "Class_term_argument" | Debug_printer_argument -> fprintf ppf "Debug_printer_argument" | Recmod_fun_arg -> fprintf ppf "Recmod_fun_arg" - | Mutable_value -> fprintf ppf "Mutable_value" | Unknown s -> fprintf ppf "Unknown %s" s let product_creation_reason ppf : History.product_creation_reason -> _ = diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index b9a68f262a2..9dbfecbb8f6 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -74,8 +74,6 @@ module type Sort = sig val for_instance_var : t - val for_mutable_var : t - val for_lazy_body : t val for_tuple_element : t @@ -210,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]. *) @@ -299,7 +298,6 @@ module History = struct | Class_term_argument | Debug_printer_argument | Recmod_fun_arg - | Mutable_value | Unknown of string (* CR layouts: get rid of these *) type immediate_creation_reason = @@ -325,6 +323,7 @@ module History = struct | Wildcard | Unification_var | Array_type_argument + | Mutable_value type product_creation_reason = | Unboxed_tuple diff --git a/typing/jkind_types.ml b/typing/jkind_types.ml index 84a588b0ff3..0326906b831 100644 --- a/typing/jkind_types.ml +++ b/typing/jkind_types.ml @@ -138,8 +138,6 @@ module Sort = struct let for_instance_var = value - let for_mutable_var = value - let for_class_arg = value let for_method = value diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 670653aa812..83332bc5047 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -618,7 +618,7 @@ 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) -> + | Texp_setmutvar (lid, _, e) -> line i ppf "Texp_setmutvar %a\n" fmt_ident lid.txt; expression i ppf e; | Texp_override (_, l) -> diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 26490a8236d..b645059a18f 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -423,7 +423,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_setinstvar (_, _, s, exp) -> iter_loc sub s; sub.expr sub exp - | Texp_setmutvar (id, exp) -> + | Texp_setmutvar (id, _, exp) -> iter_loc sub id; sub.expr sub exp | Texp_override (_, list) -> diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 8199157481a..eab5f5edce5 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -579,8 +579,8 @@ let expr sub x = map_loc sub id, sub.expr sub exp ) - | Texp_setmutvar (id, exp) -> - Texp_setmutvar (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 e1c555b9d75..42c7ac9ab36 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1434,7 +1434,6 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = } | Pcl_let (rec_flag, sdefs, scl') -> let (defs, val_env) = - (* jra: should this be hard-coded? *) Typecore.type_let In_class_def val_env Immutable rec_flag sdefs in let (vals, met_env) = List.fold_right diff --git a/typing/typecore.ml b/typing/typecore.ml index c0af454953c..1ca3acbc1af 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1157,7 +1157,7 @@ type pattern_variable = pv_id: Ident.t; pv_uid: Uid.t; pv_mode: Value.l; - (* jra: I don't fully understand the difference between mutable_flag and mutability *) + (* jra: use mutability *) pv_mutable: mutable_flag; pv_type: type_expr; pv_loc: Location.t; @@ -1263,7 +1263,6 @@ let iter_pattern_variables_type_mut ~f_immut ~f_mut pvs = let add_pattern_variables ?check ?check_as env pv = List.fold_right - (* jra: should this be modified? *) (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 @@ -1975,8 +1974,8 @@ let type_for_loop_index ~loc ~env ~param = 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_mutable=Immutable; pv_type; pv_loc; pv_as_var; pv_attributes } - (* jra: is this right? See add_pattern_variables# *) + 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]) @@ -1997,12 +1996,12 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps = pv_loc name pv_mode - Immutable (* jr: is this right? *) + Immutable pv_type pv_attributes) -let value_bindings_mutability (mutable_flag : mutable_flag) env ?restriction vbs = - match vbs, mutable_flag with +let value_bindings_mutability (mf : mutable_flag) env ?restriction vbs = + match vbs, mf with | vb :: vbs, Mutable -> begin let loc = vb.pvb_pat.ppat_loc in (* If mutable attribute is present, check: @@ -2652,7 +2651,8 @@ let rec type_pat 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 ~mutable_flag ~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 @@ -2856,7 +2856,8 @@ and type_pat_aux cross_left !!penv expected_ty alloc_mode.mode in let id, uid = - enter_variable tps loc name alloc_mode mutable_flag 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); @@ -2898,8 +2899,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 mutable_flag 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=[]; @@ -4789,8 +4790,9 @@ 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_letmutable(_, e) | Texp_sequence (_, _, e) - | Texp_open (_, e) | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) + | Texp_let (_, _, e) | Texp_letmutable(_, e) + | Texp_sequence (_, _, e) | Texp_open (_, e) + | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) | Texp_exclave e -> check e | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ -> @@ -5844,8 +5846,8 @@ and type_expect_ else Modules_rejected in let (pat_exp_list, new_env) = - type_let existential_context env mutable_flag 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 @@ -6480,13 +6482,14 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } end - | Pexp_setinstvar (lab, snewval) -> + | 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_default (Mode.Value.max_with (Comonadic Areality) Mode.Regionality.global)) + (mode_default (Mode.Value.max_with (Comonadic Areality) + Mode.Regionality.global)) snewval (mk_expected (instance ty)) in let (path_self, _) = @@ -6501,7 +6504,19 @@ and type_expect_ snewval (mk_expected (instance ty)) in let lid = {txt = id; loc} in - Texp_setmutvar(lid, newval) + let sort = + match + Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment + ~fixed:false env newval.exp_type + with + | Ok sort -> sort + | Error _ -> + (* unreachable since [x <- e] was already type-checked, + so [e] is representable *) + fatal_error "Typecore.type_exp_: \ + non-representable mutable variable assignment" + in + Texp_setmutvar(lid, sort, newval) in rue { exp_desc = desc; @@ -9326,9 +9341,8 @@ and type_let ?check ?check_strict ?(force_toplevel = false) if maybe_expansive exp then lower_contravariant env pat.pat_type) mode_pat_typ_list exp_list; iter_pattern_variables_type_mut - (* CR-someday let_mutable: jkind should be sort *) ~f_immut:generalize - ~f_mut:(unify_var env (newvar (Jkind.Builtin.value ~why:Mutable_value))) + ~f_mut:(unify_var env (newvar (Jkind.Builtin.any ~why:Mutable_value))) pvs; (* update pattern variable jkind reasons *) List.iter @@ -10136,7 +10150,8 @@ let type_binding env mutable_flag rec_flag ?force_toplevel 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 mutable_flag 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) diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 65fe9546b81..1b4bbeda1f0 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -279,7 +279,7 @@ and expression_desc = | 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 * 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 9ca253e615c..46a52c842c0 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -484,7 +484,7 @@ and expression_desc = | 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 * 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 20f8c7a88d9..20bdb8d1a4e 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3100,7 +3100,6 @@ 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) = - (* jra: should this be hard-coded? *) Typecore.type_binding env Immutable rec_flag ~force_toplevel sdefs in let defs = match rec_flag with | Recursive -> Typecore.annotate_recursive_bindings env defs diff --git a/typing/types.ml b/typing/types.ml index 1e005f8a652..8195b8ad3a4 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -445,7 +445,7 @@ module Vars = Misc.Stdlib.String.Map type value_kind = Val_reg (* Regular value *) - | Val_mut (* Mutable value (let mutable x = ...) *) + | Val_mut (* Mutable value (let mutable x = ..) *) | 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 9ede95f0bc4..6989e648488 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -584,7 +584,7 @@ module Vars : Map.S with type key = string type value_kind = Val_reg (* Regular value *) - | Val_mut (* Mutable value (let mutable x = ...) *) + | Val_mut (* Mutable value (let mutable x = ..) *) | 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 3bb0f5ccb61..824a7b08779 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -2340,7 +2340,7 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t = | 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_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 7a84dfa6c2c..7029373b073 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -641,11 +641,11 @@ let expression sub exp = 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) - | Texp_setmutvar(lid, 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_setinstvar (lid, sub.expr sub exp) + 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 f43abe7e258..e22e2abb7ef 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -901,7 +901,7 @@ let rec expression : Typedtree.expression -> term_judg = path pth << Dereference; expression e << Dereference; ] - | Texp_setmutvar (_id,e) -> + | Texp_setmutvar (_id,_sort,e) -> (* G |- e: m[Dereference] ----------------------