From e176a932eb23e71d562d2b67f039d7cae14f3188 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Fri, 30 May 2025 12:24:32 -0400
Subject: [PATCH 01/32] Add a test and update the parser for `let mutable`
This feature makes explicit an existing optimization which puts `ref`s
in registers or the call stack (which eliminates an allocation). See
`jane/doc/extensions/_08-miscellaneous-extensions/let-mutable.md` for more.
Most relevant functionality is tested in
`testsuite/tests/typing-local/let_mutable.ml`, though other tests have
been modified (e.g. `typing-local/alloc.ml` now makes sure `let mutable`
does not allocate).
---
file_formats/cmt_format.ml | 8 +-
.../let-mutable.md | 32 ++
lambda/matching.ml | 9 +-
lambda/matching.mli | 2 +-
lambda/transl_array_comprehension.ml | 2 +-
lambda/transl_list_comprehension.ml | 3 +-
lambda/translcore.ml | 19 +-
parsing/ast_helper.ml | 4 +-
parsing/ast_helper.mli | 4 +-
parsing/ast_invariants.ml | 2 +-
parsing/ast_iterator.ml | 4 +-
parsing/ast_mapper.ml | 6 +-
parsing/depend.ml | 4 +-
parsing/language_extension.ml | 13 +-
parsing/language_extension.mli | 1 +
parsing/parse.ml | 14 +
parsing/parser.mly | 55 ++-
parsing/parser_types.ml | 1 +
parsing/parser_types.mli | 1 +
parsing/parsetree.mli | 20 +-
parsing/pprintast.ml | 23 +-
parsing/printast.ml | 8 +-
parsing/syntaxerr.ml | 6 +
parsing/syntaxerr.mli | 3 +
printer/printast_with_mappings.ml | 8 +-
testsuite/tests/messages/spellcheck.ml | 2 +-
...et_mutable_at_toplevel.compilers.reference | 7 +
.../parse-errors/let_mutable_at_toplevel.ml | 6 +
.../let_mutable_in_class.compilers.reference | 11 +
.../parse-errors/let_mutable_in_class.ml | 12 +
.../let_mutable_in_module.compilers.reference | 7 +
.../parse-errors/let_mutable_in_module.ml | 8 +
...le_upstream_compatible.compilers.reference | 5 +
.../let_mutable_upstream_compatible.ml | 5 +
...with_function_bindings.compilers.reference | 7 +
.../let_mutable_with_function_bindings.ml | 6 +
.../locations_test.compilers.reference | 4 +-
.../tests/parsetree/source_jane_street.ml | 14 +
.../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 +
testsuite/tests/typing-local/let_mutable.ml | 363 ++++++++++++++++++
.../tests/typing-misc/typecore_errors.ml | 4 +-
tools/eqparsetree.ml | 2 +-
tools/ocamlprof.ml | 2 +-
typing/env.ml | 85 +++-
typing/env.mli | 15 +-
typing/jkind.ml | 3 +
typing/jkind_intf.ml | 1 +
typing/printtyped.ml | 8 +
typing/tast_iterator.ml | 7 +
typing/tast_mapper.ml | 5 +
typing/typeclass.ml | 2 +-
typing/typecore.ml | 255 ++++++++----
typing/typecore.mli | 12 +-
typing/typedtree.ml | 3 +
typing/typedtree.mli | 4 +
typing/typemod.ml | 2 +-
typing/types.ml | 6 +
typing/types.mli | 6 +
typing/uniqueness_analysis.ml | 9 +
typing/untypeast.ml | 15 +-
typing/value_rec_check.ml | 24 ++
utils/language_extension_kernel.ml | 2 +
utils/language_extension_kernel.mli | 1 +
utils/profile_counters_functions.ml | 2 +-
68 files changed, 1032 insertions(+), 169 deletions(-)
create mode 100644 jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
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
create mode 100644 testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference
create mode 100644 testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml
create mode 100644 testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference
create mode 100644 testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml
create mode 100644 testsuite/tests/typing-local/let_mutable.ml
diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml
index 2a01bf8d0bb..72319b55843 100644
--- a/file_formats/cmt_format.ml
+++ b/file_formats/cmt_format.ml
@@ -238,15 +238,17 @@ let iter_on_occurrences
modifs
| Texp_extension_constructor (lid, path) ->
f ~namespace:Extension_constructor exp_env path lid
- | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _
- | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_unboxed_tuple _
- | Texp_variant _ | Texp_array _
+ | Texp_constant _ | Texp_let _ | Texp_letmutable _ | Texp_function _
+ | Texp_apply _ | Texp_match _ | Texp_try _ | Texp_tuple _
+ | Texp_unboxed_tuple _ | Texp_variant _ | Texp_array _
| Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _
| Texp_send _
| Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _
| Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable
| Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_probe _
| Texp_probe_is_enabled _ | Texp_exclave _
+ (* CR-someday let_mutable: maybe iterate on mutvar? *)
+ | Texp_mutvar _ | Texp_setmutvar _
| Texp_open _ | Texp_src_pos | Texp_overwrite _ | Texp_hole _ -> ());
default_iterator.expr sub e);
diff --git a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
new file mode 100644
index 00000000000..a1d19b29ddb
--- /dev/null
+++ b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
@@ -0,0 +1,32 @@
+# The `let mutable` extension
+
+The `let mutable` extension provides a new type of `let` statement which
+declares a stack-local variable. It can be thought of as an unboxed `ref`.
+
+```ocaml
+let triangle n =
+ let mutable total = 0 in
+ for i = 1 to n do
+ total <- total + i
+ done;
+ total
+```
+
+Mutable `let` declarations may not be recursive, and they may not be used at the
+structure level or in class definitions. The pattern of a mutable `let`
+statement must be a single variable, possibly with a type annotation, e.g. `let
+mutable x, y = ..` is not allowed. Mutable `let` statements must also not use
+`and`s.
+
+Mutable variables must also not escape their scope. For example, you can't
+return a closure that closes over a mutable variable. At the moment, the mode
+checker is, sadly, not sophisticated enough to allow some constructions which
+are obviously safe. For example, the following code is safe, but rejected by the
+mode checker.
+
+```ocaml
+let sum xs =
+ let mutable total = 0 in
+ List.iter xs ~f:(fun x -> total <- total + x);
+ total
+```
diff --git a/lambda/matching.ml b/lambda/matching.ml
index b3db2f6da2c..0adcaad2e40 100644
--- a/lambda/matching.ml
+++ b/lambda/matching.ml
@@ -4271,7 +4271,7 @@ let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam =
in
List.fold_left push_sublet exit rev_sublets
-let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
+let for_let ~scopes ~arg_sort ~return_layout loc param mutable_flag pat body =
match pat.pat_desc with
| Tpat_any ->
(* This eliminates a useless variable (and stack slot in bytecode)
@@ -4287,7 +4287,10 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
non-polymorphic Ppat_constraint case in type_pat_aux.
*)
let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in
- Llet (Strict, k, id, duid, param, body)
+ begin match mutable_flag with
+ | Asttypes.Mutable -> Lmutlet (k, id, duid, param, body)
+ | Asttypes.Immutable -> Llet (Strict, k, id, duid, param, body)
+ end
| _ ->
let opt = ref false in
let nraise = next_raise_count () in
@@ -4511,7 +4514,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 4ccfde57c9b..2a01bece90f 100644
--- a/lambda/transl_array_comprehension.ml
+++ b/lambda/transl_array_comprehension.ml
@@ -515,7 +515,7 @@ let iterator ~transl_exp ~scopes ~loc :
iter_arr_mut ),
[iter_arr.var; Lvar iter_ix],
loc ))
- pattern body
+ Immutable pattern body
}
in
mk_iterator, Array { iter_arr; iter_len }
diff --git a/lambda/transl_list_comprehension.ml b/lambda/transl_list_comprehension.ml
index 288239ac766..f28585d36f4 100644
--- a/lambda/transl_list_comprehension.ml
+++ b/lambda/transl_list_comprehension.ml
@@ -206,7 +206,8 @@ let iterator ~transl_exp ~scopes = function
add_bindings =
(* CR layouts: to change when we allow non-values in sequences *)
Matching.for_let ~scopes ~arg_sort:Jkind.Sort.Const.for_list_element
- ~return_layout:layout_any_value pattern.pat_loc (Lvar element) pattern
+ ~return_layout:layout_any_value pattern.pat_loc (Lvar element)
+ Immutable pattern
}
(** Translates a list comprehension binding
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
index ee18c8aded7..a4007283bd9 100644
--- a/lambda/translcore.ml
+++ b/lambda/translcore.ml
@@ -393,6 +393,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
@@ -951,11 +955,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
let self = transl_value_path loc e.exp_env path_self in
let var = transl_value_path loc e.exp_env path in
Lprim(Pfield_computed Reads_vary, [self; var], loc)
+ | Texp_mutvar id -> Lmutvar id.txt
| Texp_setinstvar(path_self, path, _, expr) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
let var = transl_value_path loc e.exp_env path in
transl_setinstvar ~scopes loc self var expr
+ | Texp_setmutvar(id, expr_sort, expr) ->
+ Lassign(id.txt, transl_exp ~scopes
+ (Jkind.Sort.default_for_transl_and_get expr_sort) expr)
| Texp_override(path_self, modifs) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
@@ -1878,7 +1886,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 ->
@@ -1902,6 +1910,15 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false)
let lam_bds = List.map2 transl_case pat_expr_list idlist in
fun body -> Value_rec_compiler.compile_letrec lam_bds body
+and transl_letmutable ~scopes ~return_layout
+ {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc; vb_sort} body =
+ let arg_sort = Jkind_types.Sort.default_to_value_and_get vb_sort in
+ let lam =
+ transl_bound_exp ~scopes ~in_structure:false pat arg_sort expr vb_loc attr
+ in
+ Matching.for_let ~scopes ~return_layout ~arg_sort pat.pat_loc lam Mutable
+ pat body
+
and transl_setinstvar ~scopes loc self var expr =
let ptr_or_imm, _ = maybe_pointer expr in
Lprim(Psetfield_computed (ptr_or_imm, Assignment modify_heap),
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 7467044335e..3eae30e306d 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -212,7 +212,7 @@ module Exp = struct
let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
- let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+ let let_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_let (a, b, c, d))
let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c))
let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
@@ -236,7 +236,7 @@ module Exp = struct
let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
- let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+ let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setvar (a, b))
let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 146b9297560..753cca26902 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -150,8 +150,8 @@ module Exp:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
- val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
- -> expression -> expression
+ val let_: ?loc:loc -> ?attrs:attrs -> mutable_flag -> rec_flag ->
+ value_binding list -> expression -> expression
val function_ : ?loc:loc -> ?attrs:attrs -> function_param list
-> function_constraint -> function_body
-> expression
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
index bd82cbe7c69..8108a81efd8 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)
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index f38dae2f091..5d802a21fda 100644
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -462,7 +462,7 @@ module E = struct
match desc with
| Pexp_ident x -> iter_loc sub x
| Pexp_constant _ -> ()
- | Pexp_let (_r, vbs, e) ->
+ | Pexp_let (_m, _r, vbs, e) ->
List.iter (sub.value_binding sub) vbs;
sub.expr sub e
| Pexp_function (params, constraint_, body) ->
@@ -510,7 +510,7 @@ module E = struct
sub.modes sub m
| Pexp_send (e, _s) -> sub.expr sub e
| Pexp_new lid -> iter_loc sub lid
- | Pexp_setinstvar (s, e) ->
+ | Pexp_setvar (s, e) ->
iter_loc sub s; sub.expr sub e
| Pexp_override sel ->
List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 1d83c76c2b5..84fe9a86c81 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -531,8 +531,8 @@ module E = struct
match desc with
| Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
- | Pexp_let (r, vbs, e) ->
- let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ | Pexp_let (m, r, vbs, e) ->
+ let_ ~loc ~attrs m r (List.map (sub.value_binding sub) vbs)
(sub.expr sub e)
| Pexp_function (ps, c, b) ->
function_ ~loc ~attrs
@@ -585,7 +585,7 @@ module E = struct
| Pexp_send (e, s) ->
send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
| Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
- | Pexp_setinstvar (s, e) ->
+ | Pexp_setvar (s, e) ->
setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
| Pexp_override sel ->
override ~loc ~attrs
diff --git a/parsing/depend.ml b/parsing/depend.ml
index 4868bd9dfc7..10e7290f5ba 100644
--- a/parsing/depend.ml
+++ b/parsing/depend.ml
@@ -240,7 +240,7 @@ let rec add_expr bv exp =
match exp.pexp_desc with
Pexp_ident l -> add bv l
| Pexp_constant _ -> ()
- | Pexp_let(rf, pel, e) ->
+ | Pexp_let(_mf, rf, pel, e) ->
let bv = add_bindings rf bv pel in add_expr bv e
| Pexp_function (params, constraint_, body) ->
let bv = List.fold_left add_function_param bv params in
@@ -276,7 +276,7 @@ let rec add_expr bv exp =
Option.iter (add_type bv) ty2
| Pexp_send(e, _m) -> add_expr bv e
| Pexp_new li -> add bv li
- | Pexp_setinstvar(_v, e) -> add_expr bv e
+ | Pexp_setvar(_v, e) -> add_expr bv e
| Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in
diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml
index f7d392159de..e9b32df0f7d 100644
--- a/parsing/language_extension.ml
+++ b/parsing/language_extension.ml
@@ -74,6 +74,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
| Small_numbers -> (module Maturity)
| Instances -> (module Unit)
| Separability -> (module Unit)
+ | Let_mutable -> (module Unit)
(* We'll do this in a more principled way later. *)
(* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
@@ -87,7 +88,7 @@ let is_erasable : type a. a t -> bool = function
| Mode | Unique | Overwriting | Layouts -> true
| Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
| Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances
- | Separability ->
+ | Separability | Let_mutable ->
false
let maturity_of_unique_for_drf = Stable
@@ -112,6 +113,7 @@ module Exist_pair = struct
| Pair (Small_numbers, m) -> m
| Pair (Instances, ()) -> Stable
| Pair (Separability, ()) -> Stable
+ | Pair (Let_mutable, ()) -> Stable
let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext
@@ -125,7 +127,7 @@ module Exist_pair = struct
| Pair
( (( Comprehensions | Include_functor | Polymorphic_parameters
| Immutable_arrays | Module_strengthening | Labeled_tuples
- | Instances | Overwriting | Separability ) as ext),
+ | Instances | Overwriting | Separability | Let_mutable ) as ext),
_ ) ->
to_string ext
@@ -158,6 +160,7 @@ module Exist_pair = struct
| "small_numbers_beta" -> Some (Pair (Small_numbers, Beta))
| "instances" -> Some (Pair (Instances, ()))
| "separability" -> Some (Pair (Separability, ()))
+ | "let_mutable" -> Some (Pair (Let_mutable, ()))
| _ -> None
end
@@ -179,7 +182,8 @@ let all_extensions =
Pack Labeled_tuples;
Pack Small_numbers;
Pack Instances;
- Pack Separability ]
+ Pack Separability;
+ Pack Let_mutable ]
(**********************************)
(* string conversions *)
@@ -219,10 +223,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option =
| Small_numbers, Small_numbers -> Some Refl
| Instances, Instances -> Some Refl
| Separability, Separability -> Some Refl
+ | Let_mutable, Let_mutable -> Some Refl
| ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
| Polymorphic_parameters | Immutable_arrays | Module_strengthening
| Layouts | SIMD | Labeled_tuples | Small_numbers | Instances
- | Separability ),
+ | Separability | Let_mutable ),
_ ) ->
None
diff --git a/parsing/language_extension.mli b/parsing/language_extension.mli
index 005829fb821..869fbf44e04 100644
--- a/parsing/language_extension.mli
+++ b/parsing/language_extension.mli
@@ -32,6 +32,7 @@ type 'a t = 'a Language_extension_kernel.t =
| Small_numbers : maturity t
| Instances : unit t
| Separability : unit t
+ | Let_mutable : unit t
(** Require that an extension is enabled for at least the provided level, or
else throw an exception at the provided location saying otherwise. *)
diff --git a/parsing/parse.ml b/parsing/parse.ml
index 1b3f6da349a..aeabdd1c6df 100644
--- a/parsing/parse.ml
+++ b/parsing/parse.ml
@@ -178,6 +178,20 @@ let prepare_error err =
| Malformed_instance_identifier loc ->
Location.errorf ~loc
"Syntax error: Unexpected in module instance"
+ | Let_mutable_not_allowed_at_structure_level loc ->
+ Location.errorf ~loc
+ "Syntax error: Mutable let bindings are not allowed \
+ at the structure level."
+ | Let_mutable_not_allowed_in_class_definition loc ->
+ Location.errorf ~loc
+ "Syntax error: Mutable let bindings are not allowed \
+ inside class definitions."
+ | Let_mutable_not_allowed_with_function_bindings loc ->
+ Location.errorf ~loc
+ "Syntax error: Mutable let is not allowed with function bindings.\n\
+ @{<hint>Hint@}: If you really want a mutable function variable, \
+ use the de-sugared syntax:\n %a"
+ Style.inline_code "let mutable f = fun x -> .."
let () =
Location.register_error_of_exn
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 42c8571f992..c99a3d9e732 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -670,9 +670,10 @@ let addlb lbs lb =
if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error ();
{ lbs with lbs_bindings = lb :: lbs.lbs_bindings }
-let mklbs ext rf lb =
+let mklbs ext mf rf lb =
let lbs = {
lbs_bindings = [];
+ lbs_mutable = mf;
lbs_rec = rf;
lbs_extension = ext;
} in
@@ -689,10 +690,27 @@ let val_of_let_bindings ~loc lbs =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
- let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
- match lbs.lbs_extension with
- | None -> str
- | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+ match lbs.lbs_mutable with
+ | Mutable ->
+ raise (Syntaxerr.Error
+ (Syntaxerr.Let_mutable_not_allowed_at_structure_level (make_loc loc)))
+ | Immutable ->
+ let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+ match lbs.lbs_extension with
+ | None -> str
+ | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
+
+
+(* Find the location of the first binding in [bindings] that contains a ghost
+ * function expression. This is used to disallow [let mutable f x y = ..]. *)
+let ghost_fun_binding_loc bindings =
+ List.find_opt (fun binding ->
+ match binding.lb_expression.pexp_loc.loc_ghost,
+ binding.lb_expression.pexp_desc
+ with
+ | true, Pexp_function _ -> true | _ -> false)
+ bindings
+ |> Option.map (fun binding -> binding.lb_loc)
let expr_of_let_bindings ~loc lbs body =
let bindings =
@@ -703,7 +721,16 @@ let expr_of_let_bindings ~loc lbs body =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
- mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+ (* Disallow [let mutable f x y = ..] but still allow
+ * [let mutable f = fun x y -> ..]. *)
+ match lbs.lbs_mutable, ghost_fun_binding_loc lbs.lbs_bindings with
+ | Mutable, Some loc ->
+ raise (Syntaxerr.Error
+ (* jra: rename error *)
+ (Syntaxerr.Let_mutable_not_allowed_with_function_bindings loc))
+ | _ ->
+ mkexp_attrs ~loc
+ (Pexp_let(lbs.lbs_mutable, lbs.lbs_rec, List.rev bindings, body))
(lbs.lbs_extension, [])
let class_of_let_bindings ~loc lbs body =
@@ -715,9 +742,14 @@ let class_of_let_bindings ~loc lbs body =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
- (* Our use of let_bindings(no_ext) guarantees the following: *)
- assert (lbs.lbs_extension = None);
- mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+ match lbs.lbs_mutable with
+ | Mutable ->
+ raise (Syntaxerr.Error
+ (Syntaxerr.Let_mutable_not_allowed_in_class_definition (make_loc loc)))
+ | Immutable ->
+ (* Our use of let_bindings(no_ext) guarantees the following: *)
+ assert (lbs.lbs_extension = None);
+ mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
(* If all the parameters are [Pparam_newtype x], then return [Some xs] where
[xs] is the corresponding list of values [x]. This function is optimized for
@@ -2805,7 +2837,7 @@ fun_expr:
{ mkexp_cons ~loc:$sloc $loc($2)
(ghexp ~loc:$sloc (Pexp_tuple[None, $1;None, $3])) }
| mkrhs(label) LESSMINUS expr
- { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
+ { mkexp ~loc:$sloc (Pexp_setvar($1, $3)) }
| simple_expr DOT mkrhs(label_longident) LESSMINUS expr
{ mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
| indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v})
@@ -3230,12 +3262,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 258ae986a3f..655ecd47d06 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -365,12 +365,18 @@ and expression_desc =
| Pexp_constant of constant
(** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l],
[1L], [1n] *)
- | Pexp_let of rec_flag * value_binding list * expression
- (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents:
+ | Pexp_let of mutable_flag * rec_flag * value_binding list * expression
+ (** [Pexp_let(mut, rec, [(P1,E1) ; ... ; (Pn,En)], E)] represents:
- [let P1 = E1 and ... and Pn = EN in E]
- when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]},
+ when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}
+ and [mut] = {{!Asttypes.mutable_flag.Immutable}[Immutable]}.
- [let rec P1 = E1 and ... and Pn = EN in E]
- when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}.
+ when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}
+ and [mut] = {{!Asttypes.mutable_flag.Immutable}[Immutable]}.
+ - [let mutable P1 = E1 in E]
+ when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}
+ and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}.
+ Invariant: If [mut = Mutable] then [n = 1] and [rec = Nonrecursive]
*)
| Pexp_function of
function_param list * function_constraint * function_body
@@ -469,7 +475,11 @@ and expression_desc =
*)
| Pexp_send of expression * label loc (** [E # m] *)
| Pexp_new of Longident.t loc (** [new M.c] *)
- | Pexp_setinstvar of label loc * expression (** [x <- 2] *)
+ | Pexp_setvar of label loc * expression
+ (** [x <- 2]
+
+ Represents both setting an instance variable
+ and setting a mutable variable. *)
| Pexp_override of (label loc * expression) list
(** [{< x1 = E1; ...; xn = En >}] *)
| Pexp_letmodule of string option loc * module_expr * expression
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 55941acd81b..c1732d1316e 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -995,12 +995,13 @@ and expression ctxt f x =
pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
(* "try@;@[<2>%a@]@\nwith@\n%a"*)
(expression reset_ctxt) e (case_list ctxt) l
- | Pexp_let (rf, l, e) ->
+ | Pexp_let (mf, rf, l, e) ->
(* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
(*no indentation here, a new line*) *)
(* rec_flag rf *)
+ (* mutable_flag mf *)
pp f "@[<2>%a in@;<1 -2>%a@]"
- (bindings reset_ctxt) (rf,l)
+ (bindings reset_ctxt) (mf,rf,l)
(expression ctxt) e
| Pexp_apply
({ pexp_desc = Pexp_extension({txt = "extension.exclave"}, PStr []) },
@@ -1080,7 +1081,7 @@ and expression ctxt f x =
(list (expression (under_semi ctxt)) ~sep:";@;") lst
| Pexp_new (li) ->
pp f "@[<hov2>new@ %a@]" longident_loc li;
- | Pexp_setinstvar (s, e) ->
+ | Pexp_setvar (s, e) ->
pp f "@[<hov2>%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e
| Pexp_override l -> (* FIXME *)
let string_x_expression f (s, e) =
@@ -1412,7 +1413,7 @@ and class_expr ctxt f x =
(class_expr ctxt) e
| Pcl_let (rf, l, ce) ->
pp f "%a@ in@ %a"
- (bindings ctxt) (rf,l)
+ (bindings ctxt) (Immutable,rf,l)
(class_expr ctxt) ce
| Pcl_apply (ce, l) ->
pp f "((%a)@ %a)" (* Cf: #7200 *)
@@ -1818,8 +1819,8 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; pvb_modes = mode
end
(* [in] is not printed *)
-and bindings ctxt f (rf,l) =
- let binding kwd rf f x =
+and bindings ctxt f (mf,rf,l) =
+ let binding kwd mf rf f x =
(* The other modes are printed inside [binding] *)
let legacy, x =
if print_modes_in_old_syntax x.pvb_modes then
@@ -1827,18 +1828,18 @@ and bindings ctxt f (rf,l) =
else
[], x
in
- pp f "@[<2>%s %a%a%a@]%a" kwd rec_flag rf
+ pp f "@[<2>%s %a%a%a%a@]%a" kwd mutable_flag mf rec_flag rf
optional_legacy_modes legacy
(binding ctxt) x
(item_attributes ctxt) x.pvb_attributes
in
match l with
| [] -> ()
- | [x] -> binding "let" rf f x
+ | [x] -> binding "let" mf rf f x
| x::xs ->
pp f "@[<v>%a@,%a@]"
- (binding "let" rf) x
- (list ~sep:"@," (binding "and" Nonrecursive)) xs
+ (binding "let" mf rf) x
+ (list ~sep:"@," (binding "and" Immutable Nonrecursive)) xs
and binding_op ctxt f x =
match x.pbop_pat, x.pbop_exp with
@@ -1860,7 +1861,7 @@ and structure_item ctxt f x =
| Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l)
| Pstr_value (rf, l) ->
(* pp f "@[<hov2>let %a%a@]" rec_flag rf bindings l *)
- pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+ pp f "@[<2>%a@]" (bindings ctxt) (Immutable,rf,l)
| Pstr_typext te -> type_extension ctxt f te
| Pstr_exception ed -> exception_declaration ctxt f ed
| Pstr_module x ->
diff --git a/parsing/printast.ml b/parsing/printast.ml
index ce78866d0da..3af933cd04c 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -310,8 +310,8 @@ and expression i ppf x =
match x.pexp_desc with
| Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
| Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
- | Pexp_let (rf, l, e) ->
- line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+ | Pexp_let (mf, rf, l, e) ->
+ line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf;
list i value_binding ppf l;
expression i ppf e;
| Pexp_function (params, c, body) ->
@@ -400,8 +400,8 @@ and expression i ppf x =
line i ppf "Pexp_send \"%s\"\n" s.txt;
expression i ppf e;
| Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
- | Pexp_setinstvar (s, e) ->
- line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+ | Pexp_setvar (s, e) ->
+ line i ppf "Pexp_setvar %a\n" fmt_string_loc s;
expression i ppf e;
| Pexp_override (l) ->
line i ppf "Pexp_override\n";
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index c1dbac71d7b..9ff59817696 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -35,6 +35,9 @@ type error =
| Removed_string_set of Location.t
| Missing_unboxed_literal_suffix of Location.t
| Malformed_instance_identifier of Location.t
+ | Let_mutable_not_allowed_at_structure_level of Location.t
+ | Let_mutable_not_allowed_in_class_definition of Location.t
+ | Let_mutable_not_allowed_with_function_bindings of Location.t
exception Error of error
exception Escape_error
@@ -51,6 +54,9 @@ let location_of_error = function
| Removed_string_set l -> l
| Missing_unboxed_literal_suffix l -> l
| Malformed_instance_identifier l -> l
+ | Let_mutable_not_allowed_at_structure_level l -> l
+ | Let_mutable_not_allowed_in_class_definition l -> l
+ | Let_mutable_not_allowed_with_function_bindings l -> l
let ill_formed_ast loc s =
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 47f2910fd0e..ffae83098df 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -40,6 +40,9 @@ type error =
| Removed_string_set of Location.t
| Missing_unboxed_literal_suffix of Location.t
| Malformed_instance_identifier of Location.t
+ | Let_mutable_not_allowed_at_structure_level of Location.t
+ | Let_mutable_not_allowed_in_class_definition of Location.t
+ | Let_mutable_not_allowed_with_function_bindings of Location.t
exception Error of error
exception Escape_error
diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml
index ca665202272..d00cab6f149 100644
--- a/printer/printast_with_mappings.ml
+++ b/printer/printast_with_mappings.ml
@@ -334,8 +334,8 @@ and expression i ppf x =
match x.pexp_desc with
| Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
| Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
- | Pexp_let (rf, l, e) ->
- line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+ | Pexp_let (mf, rf, l, e) ->
+ line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf;
list i value_binding ppf l;
expression i ppf e;
| Pexp_function (params, c, body) ->
@@ -424,8 +424,8 @@ and expression i ppf x =
line i ppf "Pexp_send \"%s\"\n" s.txt;
expression i ppf e;
| Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
- | Pexp_setinstvar (s, e) ->
- line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+ | Pexp_setvar (s, e) ->
+ line i ppf "Pexp_setvar %a\n" fmt_string_loc s;
expression i ppf e;
| Pexp_override (l) ->
line i ppf "Pexp_override\n";
diff --git a/testsuite/tests/messages/spellcheck.ml b/testsuite/tests/messages/spellcheck.ml
index c403d92fa15..062771fbbd6 100644
--- a/testsuite/tests/messages/spellcheck.ml
+++ b/testsuite/tests/messages/spellcheck.ml
@@ -124,7 +124,7 @@ let _ =
Line 5, characters 22-33:
5 | method update n = foobaz <- n
^^^^^^^^^^^
-Error: The value "foobaz" is not an instance variable
+Error: The value "foobaz" is not an instance variable or mutable variable
Hint: Did you mean "foobar"?
|}];;
diff --git a/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference b/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference
new file mode 100644
index 00000000000..4096b7014b6
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.compilers.reference
@@ -0,0 +1,7 @@
+
+
+Line 6, characters 0-18:
+6 | let mutable x = 10
+ ^^^^^^^^^^^^^^^^^^
+Error: Syntax error: Mutable let bindings are not allowed at the structure level.
+
diff --git a/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml b/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml
new file mode 100644
index 00000000000..18da66759af
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_at_toplevel.ml
@@ -0,0 +1,6 @@
+(* TEST
+ flags = "-extension let_mutable";
+ toplevel; *)
+
+(* let mutable not allowed at structure level *)
+let mutable x = 10
diff --git a/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference b/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference
new file mode 100644
index 00000000000..2373afa053f
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_in_class.compilers.reference
@@ -0,0 +1,11 @@
+
+
+Lines 7-12, characters 2-5:
+ 7 | ..let mutable x = 20 in
+ 8 | object
+ 9 | method read_incr =
+10 | x <- x + 1;
+11 | x
+12 | end
+Error: Syntax error: Mutable let bindings are not allowed inside class definitions.
+
diff --git a/testsuite/tests/parse-errors/let_mutable_in_class.ml b/testsuite/tests/parse-errors/let_mutable_in_class.ml
new file mode 100644
index 00000000000..b8dc031bba3
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_in_class.ml
@@ -0,0 +1,12 @@
+(* TEST
+ flags = "-extension let_mutable";
+ toplevel; *)
+
+(* let mutable is not allowed in class definitions *)
+class c =
+ let mutable x = 20 in
+ object
+ method read_incr =
+ x <- x + 1;
+ x
+ end
diff --git a/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference b/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference
new file mode 100644
index 00000000000..e3134e4eeea
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_in_module.compilers.reference
@@ -0,0 +1,7 @@
+
+
+Line 7, characters 2-20:
+7 | let mutable x = 20
+ ^^^^^^^^^^^^^^^^^^
+Error: Syntax error: Mutable let bindings are not allowed at the structure level.
+
diff --git a/testsuite/tests/parse-errors/let_mutable_in_module.ml b/testsuite/tests/parse-errors/let_mutable_in_module.ml
new file mode 100644
index 00000000000..f5f7886c604
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_in_module.ml
@@ -0,0 +1,8 @@
+(* TEST
+ flags = "-extension let_mutable";
+ toplevel; *)
+
+(* let mutable not allowed at structure level *)
+module M = struct
+ let mutable x = 20
+end
diff --git a/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference
new file mode 100644
index 00000000000..c6009032946
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.compilers.reference
@@ -0,0 +1,5 @@
+Line 5, characters 20-21:
+5 | let _ = let mutable x = 20 in x;;
+ ^
+Error: The extension "let_mutable" is disabled and cannot be used
+
diff --git a/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml
new file mode 100644
index 00000000000..633f45061a0
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_upstream_compatible.ml
@@ -0,0 +1,5 @@
+(* TEST
+ flags = "-extension-universe upstream_compatible";
+ toplevel; *)
+
+let _ = let mutable x = 20 in x;;
diff --git a/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference
new file mode 100644
index 00000000000..e8de087c2d6
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.compilers.reference
@@ -0,0 +1,7 @@
+Line 6, characters 8-27:
+6 | let _ = let mutable f x = x in f;;
+ ^^^^^^^^^^^^^^^^^^^
+Error: Syntax error: Mutable let is not allowed with function bindings.
+Hint: If you really want a mutable function variable, use the de-sugared syntax:
+ "let mutable f = fun x -> .."
+
diff --git a/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml
new file mode 100644
index 00000000000..fee091acd64
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_with_function_bindings.ml
@@ -0,0 +1,6 @@
+(* TEST
+ flags = "-extension let_mutable";
+ toplevel; *)
+
+(* let mutable not allowed with function bindings *)
+let _ = let mutable f x = x in f;;
diff --git a/testsuite/tests/parsetree/locations_test.compilers.reference b/testsuite/tests/parsetree/locations_test.compilers.reference
index 48cbb759383..a3afe02b733 100644
--- a/testsuite/tests/parsetree/locations_test.compilers.reference
+++ b/testsuite/tests/parsetree/locations_test.compilers.reference
@@ -1341,7 +1341,7 @@ Ptop_def
structure_item (//toplevel//[2,1+0]..[5,76+12])
Pstr_eval
expression (//toplevel//[2,1+0]..[5,76+12])
- Pexp_let Nonrec
+ Pexp_let Immutable Nonrec
[
<def>
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
[
<def>
pattern (//toplevel//[4,76+6]..[4,76+7])
diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml
index 10a4b32a87f..646b6074bad 100644
--- a/testsuite/tests/parsetree/source_jane_street.ml
+++ b/testsuite/tests/parsetree/source_jane_street.ml
@@ -1481,3 +1481,17 @@ let f g here = g ~(here : [%call_pos])
[%%expect{|
val f : (here:[%call_pos] -> 'a) -> lexing_position -> 'a = <fun>
|}]
+
+(***************)
+(* let mutable *)
+
+let triangle_10 = let mutable x = 0 in
+ for i = 1 to 10 do
+ x <- x + i
+ done;
+ x
+;;
+
+[%%expect{|
+val triangle_10 : int = 55
+|}]
diff --git a/testsuite/tests/parsing/extensions.compilers.reference b/testsuite/tests/parsing/extensions.compilers.reference
index eebe76cecc5..a8c4e4cb753 100644
--- a/testsuite/tests/parsing/extensions.compilers.reference
+++ b/testsuite/tests/parsing/extensions.compilers.reference
@@ -5,7 +5,7 @@
structure_item (extensions.ml[9,153+7]..[9,153+21])
Pstr_eval
expression (extensions.ml[9,153+7]..[9,153+21])
- Pexp_let Nonrec
+ Pexp_let Immutable Nonrec
[
<def>
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
[
<def>
attribute "foo"
diff --git a/testsuite/tests/typing-local/alloc.heap.reference b/testsuite/tests/typing-local/alloc.heap.reference
index 8a7449cbf7d..e4827df2031 100644
--- a/testsuite/tests/typing-local/alloc.heap.reference
+++ b/testsuite/tests/typing-local/alloc.heap.reference
@@ -36,3 +36,4 @@
optionaleta: Allocation
object: Allocation
object_direct: Allocation
+ let_mutable: Allocation
diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml
index a6672d8e30c..18420c1cd76 100644
--- a/testsuite/tests/typing-local/alloc.ml
+++ b/testsuite/tests/typing-local/alloc.ml
@@ -1,4 +1,5 @@
(* TEST
+ flags = "-extension let_mutable";
{
reference = "${test_source_directory}/alloc.heap.reference";
bytecode;
@@ -470,6 +471,13 @@ let obj_direct () =
end);
()
+let let_mutable_loop () =
+ let mutable x = [] in
+ for i = 0 to 10 do exclave_
+ x <- stack_ (i :: x)
+ done;
+ ignore_local x
+
let run name f x =
let prebefore = Gc.allocated_bytes () in
let before = Gc.allocated_bytes () in
@@ -525,7 +533,8 @@ let () =
run "optionalarg" optionalarg (fun_with_optional_arg, 10);
run "optionaleta" optionaleta ();
run "object" obj ();
- run "object_direct" obj_direct ()
+ run "object_direct" obj_direct ();
+ run "let_mutable" let_mutable_loop ()
(* The following test commented out as it require more memory than the CI has
*)
diff --git a/testsuite/tests/typing-local/alloc.stack.reference b/testsuite/tests/typing-local/alloc.stack.reference
index b635f9fe36f..998fd416a87 100644
--- a/testsuite/tests/typing-local/alloc.stack.reference
+++ b/testsuite/tests/typing-local/alloc.stack.reference
@@ -36,3 +36,4 @@
optionaleta: No Allocation
object: Allocation
object_direct: Allocation
+ let_mutable: No Allocation
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
new file mode 100644
index 00000000000..d52679ef46b
--- /dev/null
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -0,0 +1,363 @@
+(* TEST
+ flags = "-extension let_mutable";
+ include stdlib_upstream_compatible;
+ 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 = <fun>
+|}]
+
+(* 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 exclave_
+ x <- local_ (i :: x)
+ done;
+ match x with
+ | [] -> assert false
+ | (x :: xs) -> x
+ in
+ build_loop ()
+
+[%%expect{|
+Line 5, characters 6-26:
+5 | x <- local_ (i :: x)
+ ^^^^^^^^^^^^^^^^^^^^
+Error: 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 local out of non-local while cond region *)
+ let mutable x = y in
+ while x <- (local_ (x + 1)); x <= 100 do
+ x <- x + x
+ done; x
+
+[%%expect{|
+Line 3, characters 13-29:
+3 | while x <- (local_ (x + 1)); x <= 100 do
+ ^^^^^^^^^^^^^^^^
+Error: This value escapes its region.
+|}]
+
+let foo4_5 y =
+ let mutable x = [] in
+ for i = 1 to y do
+ for j = 1 to y do exclave_
+ x <- local_ ((i*j) :: x)
+ done
+ done;
+ x
+;;
+[%%expect{|
+Line 5, characters 11-30:
+5 | x <- local_ ((i*j) :: x)
+ ^^^^^^^^^^^^^^^^^^^
+Error: This value escapes its region.
+|}]
+
+let foo4_6 y =
+ let mutable x = [] in
+ for i = 1 to y do exclave_
+ for j = 1 to y do
+ x <- local_ ((i*j) :: x)
+ done
+ done;
+ x
+;;
+[%%expect{|
+Line 5, characters 11-30:
+5 | x <- local_ ((i*j) :: x)
+ ^^^^^^^^^^^^^^^^^^^
+Error: This value escapes its region.
+|}]
+
+
+(* Test 5: Allowed interactions with locals. *)
+let foo5_1 y = (* Assignment of local allowed in same scope *)
+ let mutable x = [] in
+ x <- (local_ (y :: x));
+ x <- (local_ (y :: x));
+ match x with
+ | [] -> assert false
+ | (x :: xs) -> x
+
+let () = assert Int.(equal 42 (foo5_1 42))
+
+let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
+ let mutable x = [] in
+ for i = 1 to y do exclave_
+ x <- local_ (i :: x)
+ done;
+ match x with
+ | [] -> assert false
+ | (x :: xs) -> x
+
+let () = assert Int.(equal 42 (foo5_2 42))
+
+let foo5_3 y = (* Assignment of local works in _local_ while body region *)
+ let mutable x = y in
+ let i = ref 1 in
+ while !i <= 10 do exclave_
+ x <- (local_ (x + !i));
+ i := !i + 1;
+ done; x
+
+let foo5_4 y = (* Assign of local works in _local_ while cond region *)
+ let mutable x = y in
+ while exclave_ x <- (local_ (x + 1)); x <= 100 do
+ x <- x + x
+ done; x
+
+[%%expect{|
+val foo5_1 : 'a -> 'a = <fun>
+val foo5_2 : int -> int = <fun>
+val foo5_3 : int -> int = <fun>
+val foo5_4 : int -> int = <fun>
+|}]
+
+(* Test 6: let mutable ... and ... is illegal *)
+let foo_6 () =
+ let mutable x = []
+ and z = 3
+ in
+ x <- z :: x;
+ match x with
+ | [] -> 0
+ | z :: _ -> z
+
+[%%expect{|
+Line 2, characters 14-15:
+2 | let mutable x = []
+ ^
+Error: Mutable let bindings are not allowed as part of a `let .. and ..' group
+|}]
+
+(* Test 7: mutable and rec don't mix *)
+let foo_7_1 () =
+ let mutable rec x = 1 :: x in
+ match x with
+ | [] -> 0
+ | _ :: _ -> 1
+
+[%%expect{|
+Line 2, characters 18-19:
+2 | let mutable rec x = 1 :: x in
+ ^
+Error: Mutable let bindings are not allowed to be recursive
+|}]
+
+(* Test 8: only variable patterns may be mutable *)
+let foo_8_1 y =
+ let mutable (x1,x2) = (y,y+1) in
+ x1 <- x1 + 10;
+ x2 <- x2 + 20;
+ (x1,x2)
+
+[%%expect {|
+Line 2, characters 14-21:
+2 | let mutable (x1,x2) = (y,y+1) in
+ ^^^^^^^
+Error: Only variables are allowed as the left-hand side of "let mutable"
+|}]
+
+type t8_2 = {x_8_2 : int}
+let foo_8_2 y =
+ let mutable {x_8_2} = {x_8_2 = y + 1} in
+ x_8_2 <- x_8_2 + 10;
+ x_8_2
+
+
+[%%expect{|
+type t8_2 = { x_8_2 : int; }
+Line 3, characters 14-21:
+3 | let mutable {x_8_2} = {x_8_2 = y + 1} in
+ ^^^^^^^
+Error: Only variables are allowed as the left-hand side of "let mutable"
+|}]
+
+(* Test 11: binding a mutable variable shouldn't be simplified away *)
+let f_11 () =
+ let mutable x = 10 in
+ let y = x in
+ x <- x + 10;
+ (y,x)
+
+let () = assert (f_11 () = (10,20))
+[%%expect{|
+val f_11 : unit -> int * int = <fun>
+|}]
+
+(* 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: modes? *)
+let reset_ref (x @ unique) = x := 0;;
+
+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 = #256.0 in
+ for i = 1 to 10 do
+ r <- div r #2.0
+ done;
+ to_float r
+;;
+(* 2^8 / 2^10 = 2^-2 *)
+[%%expect{|
+val r_15 : float = 0.25
+|}]
+
+(* Test 16: mutable variables must be representable *)
+type t_16 : any;;
+let f_16 () = let mutable x = (assert false : t_16) in ();;
+[%%expect{|
+type t_16 : any
+Line 2, characters 30-51:
+2 | let f_16 () = let mutable x = (assert false : t_16) in ();;
+ ^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type "t_16" but an expression was expected of type
+ "('a : '_representable_layout_1)"
+ The layout of t_16 is any
+ because of the definition of t_16 at line 1, characters 0-15.
+ But the layout of t_16 must be representable
+ because it's the type of a variable bound by a `let`.
+|}, Principal{|
+type t_16 : any
+Line 2, characters 26-27:
+2 | let f_16 () = let mutable x = (assert false : t_16) in ();;
+ ^
+Error: This pattern matches values of type "t_16"
+ but a pattern was expected which matches values of type
+ "('a : '_representable_layout_1)"
+ The layout of t_16 is any
+ because of the definition of t_16 at line 1, characters 0-15.
+ But the layout of t_16 must be representable
+ because it's the type of a variable bound by a `let`.
+|}]
+
+(* Test 17: mutable variables can't change type *)
+let x_17 =
+ let mutable x = 3.0 in
+ x <- 3;
+ x
+;;
+[%%expect{|
+Line 3, characters 7-8:
+3 | x <- 3;
+ ^
+Error: This expression has type "int" but an expression was expected of type
+ "float"
+ Hint: Did you mean "3."?
+|}]
diff --git a/testsuite/tests/typing-misc/typecore_errors.ml b/testsuite/tests/typing-misc/typecore_errors.ml
index 4d28a250b5e..7fb4ccf5b8c 100644
--- a/testsuite/tests/typing-misc/typecore_errors.ml
+++ b/testsuite/tests/typing-misc/typecore_errors.ml
@@ -182,7 +182,7 @@ let x = object(self) method m = self <-0 end
Line 1, characters 32-40:
1 | let x = object(self) method m = self <-0 end
^^^^^^^^
-Error: The value "self" is not an instance variable
+Error: The value "self" is not an instance variable or mutable variable
|}]
(** Multiply override *)
@@ -388,7 +388,7 @@ let o = object method m = instance <- 0 end
Line 3, characters 26-39:
3 | let o = object method m = instance <- 0 end
^^^^^^^^^^^^^
-Error: Unbound instance variable "instance"
+Error: Unbound instance variable or mutable variable "instance"
|}]
diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml
index 819d49f70e0..af4d706a1e8 100644
--- a/tools/eqparsetree.ml
+++ b/tools/eqparsetree.ml
@@ -735,7 +735,7 @@ and eq_expression_desc :
(eq_expression (a0, b0)) && (eq_string (a1, b1))
| (Pexp_new a0, Pexp_new b0) ->
Asttypes.eq_loc Longident.eq_t (a0, b0)
- | (Pexp_setinstvar (a0, a1), Pexp_setinstvar (b0, b1)) ->
+ | (Pexp_setvar (a0, a1), Pexp_setvar (b0, b1)) ->
(Asttypes.eq_loc eq_string (a0, b0)) &&
(eq_expression (a1, b1))
| (Pexp_override a0, Pexp_override b0) ->
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 699a9cfb556..6be3ef19462 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -277,7 +277,7 @@ and rw_exp iflag sexp =
| Pexp_new _ -> ()
- | Pexp_setinstvar (_, sarg) ->
+ | Pexp_setvar (_, sarg) ->
rewrite_exp iflag sarg
| Pexp_override l ->
diff --git a/typing/env.ml b/typing/env.ml
index 21757c97a0e..b7fb685309d 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 * type_declaration
| 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
@@ -3302,8 +3303,24 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks =
vmode
) vmode locks
+(** jra: write documentation *)
+let unwalk_locks ~errors:_ ~loc:_ ~env:_ ~item:_ ~lid:_ mode _ty _locks =
+ mode
+
+(** Would this set of locks prevent a mutable variable from being used?
+ The current implementation is too restrictive: Any [Closure_lock] will
+ block a mutable variable, even if the closure does not leave the mutable
+ variable's scope *)
+let blocks_mutable_variables locks =
+ List.exists (function
+ | Closure_lock _ | Escape_lock _ | Share_lock _ -> true
+ | Region_lock | Exclave_lock | Unboxed_lock -> false) 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 blocks_mutable_variables 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
@@ -4039,27 +4056,47 @@ let lookup_all_labels_from_type ?(use=true) ~record_form ~loc usage ty_path env
=
lookup_all_labels_from_type ~use ~record_form ~loc usage ty_path env
-let lookup_instance_variable ?(use=true) ~loc name env =
+type settable_variable =
+ | Instance_variable of Path.t * Asttypes.mutable_flag * string * type_expr
+ | Mutable_variable of Ident.t * Mode.Value.r * type_expr * Jkind.Sort.t
+
+let lookup_settable_variable ?(use=true) ~loc name env =
match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with
- | Ok (path, _, Val_bound vda) -> begin
+ | Ok (path, locks, Val_bound vda) -> begin
let desc = vda.vda_description in
- match desc.val_kind with
- | Val_ivar(mut, cl_num) ->
+ match desc.val_kind, path with
+ | Val_ivar(mut, cl_num), _ ->
use_value ~use ~loc path vda;
- path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type
- | _ ->
- lookup_error loc env (Not_an_instance_variable name)
+ Instance_variable
+ (path, mut, cl_num, Subst.Lazy.force_type_expr desc.val_type)
+ | Val_mut(mode_restriction, sort), Pident id ->
+ let val_type = Subst.Lazy.force_type_expr desc.val_type in
+ let mode =
+ unwalk_locks
+ ~errors:true ~loc ~env ~item:Value
+ ~lid:(Lident "")
+ mode_restriction
+ val_type
+ locks
+ in
+ use_value ~use ~loc path vda;
+ Mutable_variable (id, mode, val_type, sort)
+ | Val_mut _, _ -> assert false
+ (* Unreachable because only [type_pat] creates mutable variables
+ and it checks that they are simple identifiers. *)
+ | ((Val_reg | Val_prim _ | Val_self _ | Val_anc _), _) ->
+ lookup_error loc env (Not_a_settable_variable name)
end
| Ok (_, _, Val_unbound Val_unbound_instance_variable) ->
lookup_error loc env (Masked_instance_variable (Lident name))
| Ok (_, _, Val_unbound Val_unbound_self) ->
- lookup_error loc env (Not_an_instance_variable name)
+ lookup_error loc env (Not_a_settable_variable name)
| Ok (_, _, Val_unbound Val_unbound_ancestor) ->
- lookup_error loc env (Not_an_instance_variable name)
+ lookup_error loc env (Not_a_settable_variable name)
| Ok (_, _, Val_unbound Val_unbound_ghost_recursive _) ->
- lookup_error loc env (Unbound_instance_variable name)
+ lookup_error loc env (Unbound_settable_variable name)
| Error _ ->
- lookup_error loc env (Unbound_instance_variable name)
+ lookup_error loc env (Unbound_settable_variable name)
(* Checking if a name is bound *)
@@ -4356,11 +4393,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 =
@@ -4530,13 +4567,14 @@ let report_lookup_error _loc env ppf = function
fprintf ppf "Unbound class type %a"
(Style.as_inline_code !print_longident) lid;
spellcheck ppf extract_cltypes env lid
- | Unbound_instance_variable s ->
- fprintf ppf "Unbound instance variable %a" Style.inline_code s;
- spellcheck_name ppf extract_instance_variables env s;
- | Not_an_instance_variable s ->
- fprintf ppf "The value %a is not an instance variable"
+ | Unbound_settable_variable s ->
+ fprintf ppf "Unbound instance variable or mutable variable %a"
Style.inline_code s;
- spellcheck_name ppf extract_instance_variables env s;
+ spellcheck_name ppf extract_settable_variables env s
+ | Not_a_settable_variable s ->
+ fprintf ppf "The value %a is not an instance variable or mutable variable"
+ Style.inline_code s;
+ spellcheck_name ppf extract_settable_variables env s
| Masked_instance_variable lid ->
fprintf ppf
"The instance variable %a@ \
@@ -4661,6 +4699,11 @@ let report_lookup_error _loc env ppf = function
end
| Error_from_persistent_env err ->
Persistent_env.report_error ppf err
+ | Mutable_value_used_in_closure 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 bad3329b35d..ebbfd20b028 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,8 @@ type lookup_error =
| Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t
| No_unboxed_version of Longident.t * type_declaration
| Error_from_persistent_env of Persistent_env.error
+ | Mutable_value_used_in_closure of string
+ (* jra: Maybe rename this error/add other errors? *)
val lookup_error: Location.t -> t -> lookup_error -> 'a
@@ -337,9 +339,12 @@ val lookup_all_labels_from_type:
?use:bool -> record_form:'rcd record_form -> loc:Location.t -> label_usage -> Path.t -> t ->
('rcd gen_label_description * (unit -> unit)) list
-val lookup_instance_variable:
- ?use:bool -> loc:Location.t -> string -> t ->
- Path.t * Asttypes.mutable_flag * string * type_expr
+type settable_variable =
+ | Instance_variable of Path.t * Asttypes.mutable_flag * string * type_expr
+ | Mutable_variable of Ident.t * Mode.Value.r * type_expr * Jkind.Sort.t
+
+val lookup_settable_variable:
+ ?use:bool -> loc:Location.t -> string -> t -> settable_variable
val find_value_by_name:
Longident.t -> t -> Path.t * value_description
diff --git a/typing/jkind.ml b/typing/jkind.ml
index 2b4b6f173e7..7cc6ad8703c 100644
--- a/typing/jkind.ml
+++ b/typing/jkind.ml
@@ -3041,6 +3041,8 @@ module Format_history = struct
representable at call sites)"
| Peek_or_poke ->
fprintf ppf "it's the type being used for a peek or poke primitive"
+ | Mutable_var_assignment ->
+ fprintf ppf "it's the type of a mutable variable used in an assignment"
let format_concrete_legacy_creation_reason ppf :
History.concrete_legacy_creation_reason -> unit = function
@@ -3840,6 +3842,7 @@ module Debug_printers = struct
| Layout_poly_in_external -> fprintf ppf "Layout_poly_in_external"
| Unboxed_tuple_element -> fprintf ppf "Unboxed_tuple_element"
| Peek_or_poke -> fprintf ppf "Peek_or_poke"
+ | Mutable_var_assignment -> fprintf ppf "Mutable_var_assignment"
let concrete_legacy_creation_reason ppf :
History.concrete_legacy_creation_reason -> unit = function
diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml
index 7ffa0b1a085..58db6447850 100644
--- a/typing/jkind_intf.ml
+++ b/typing/jkind_intf.ml
@@ -214,6 +214,7 @@ module History = struct
| Layout_poly_in_external
| Unboxed_tuple_element
| Peek_or_poke
+ | Mutable_var_assignment
(* For sort variables that are in the "legacy" position
on the jkind lattice, defaulting exactly to [value]. *)
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index c2898532285..0aa71214bec 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -492,11 +492,16 @@ and expression i ppf x =
match x.exp_desc with
| Texp_ident (li,_,_,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
| Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+ | Texp_mutvar id -> line i ppf "Texp_mutvar %a\n" fmt_ident id.txt;
| Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
| Texp_let (rf, l, e) ->
line i ppf "Texp_let %a\n" fmt_rec_flag rf;
list i (value_binding rf) ppf l;
expression i ppf e;
+ | Texp_letmutable (vb, e) ->
+ line i ppf "Texp_letmutable\n";
+ value_binding Nonrecursive i ppf vb;
+ expression i ppf e
| Texp_function { params; body; alloc_mode = am } ->
line i ppf "Texp_function\n";
alloc_mode i ppf am;
@@ -616,6 +621,9 @@ and expression i ppf x =
| Texp_setinstvar (_, s, _, e) ->
line i ppf "Texp_setinstvar %a\n" fmt_path s;
expression i ppf e;
+ | Texp_setmutvar (lid, _, e) ->
+ line i ppf "Texp_setmutvar %a\n" fmt_ident lid.txt;
+ expression i ppf e;
| Texp_override (_, l) ->
line i ppf "Texp_override\n";
list i string_x_expression ppf l;
diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml
index 8003348343b..b5234fef862 100644
--- a/typing/tast_iterator.ml
+++ b/typing/tast_iterator.ml
@@ -339,6 +339,9 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} =
| Texp_let (rec_flag, list, exp) ->
sub.value_bindings sub (rec_flag, list);
sub.expr sub exp
+ | Texp_letmutable (vb, exp) ->
+ sub.value_binding sub vb;
+ sub.expr sub exp
| Texp_function { params; body; _ } ->
List.iter (function_param sub) params;
function_body sub body
@@ -416,9 +419,13 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} =
sub.expr sub exp
| Texp_new (_, lid, _, _) -> iter_loc sub lid
| Texp_instvar (_, _, s) -> iter_loc sub s
+ | Texp_mutvar id -> iter_loc sub id
| Texp_setinstvar (_, _, s, exp) ->
iter_loc sub s;
sub.expr sub exp
+ | Texp_setmutvar (id, _, exp) ->
+ iter_loc sub id;
+ sub.expr sub exp
| Texp_override (_, list) ->
List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list
| Texp_letmodule (_, s, _, mexpr, exp) ->
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index de97924586a..071bc191574 100644
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -464,6 +464,8 @@ let expr sub x =
| Texp_let (rec_flag, list, exp) ->
let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
Texp_let (rec_flag, list, sub.expr sub exp)
+ | Texp_letmutable (vb, exp) ->
+ Texp_letmutable (sub.value_binding sub vb, sub.expr sub exp)
| Texp_function { params; body; alloc_mode; ret_mode; ret_sort;
zero_alloc } ->
let params = List.map (function_param sub) params in
@@ -575,6 +577,7 @@ let expr sub x =
path2,
map_loc sub id
)
+ | Texp_mutvar id -> Texp_mutvar (map_loc sub id)
| Texp_setinstvar (path1, path2, id, exp) ->
Texp_setinstvar (
path1,
@@ -582,6 +585,8 @@ let expr sub x =
map_loc sub id,
sub.expr sub exp
)
+ | Texp_setmutvar (id, sort, exp) ->
+ Texp_setmutvar (map_loc sub id, sort, sub.expr sub exp)
| Texp_override (path, list) ->
Texp_override (
path,
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index f849b239650..84890c37bf2 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1434,7 +1434,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
}
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
- Typecore.type_let In_class_def val_env rec_flag sdefs in
+ Typecore.type_let In_class_def val_env Immutable rec_flag sdefs in
let (vals, met_env) =
List.fold_right
(fun (id, modes_and_sorts, _) (vals, met_env) ->
diff --git a/typing/typecore.ml b/typing/typecore.ml
index fdf56b176cc..b8870e79d8c 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -142,6 +142,10 @@ let print_unsupported_stack_allocation ppf = function
| List_comprehension -> Format.fprintf ppf "list comprehensions"
| Array_comprehension -> Format.fprintf ppf "array comprehensions"
+type mutable_restriction =
+ | In_group
+ | In_rec
+
type error =
| Constructor_arity_mismatch of Longident.t * int * int
| Constructor_labeled_arg
@@ -223,6 +227,7 @@ type error =
| Cannot_infer_signature
| Not_a_packed_module of type_expr
| Unexpected_existential of existential_restriction * string
+ | Unexpected_mutable of mutable_restriction
| Invalid_interval
| Invalid_for_loop_index
| Invalid_comprehension_for_range_iterator_index
@@ -244,6 +249,7 @@ type error =
| Float32_literal of string
| Illegal_letrec_pat
| Illegal_letrec_expr
+ | Illegal_mutable_pat
| Illegal_class_expr
| Letop_type_clash of string * Errortrace.unification_error
| Andop_type_clash of string * Errortrace.unification_error
@@ -276,6 +282,7 @@ type error =
| Function_type_not_rep of type_expr * Jkind.Violation.t
| Record_projection_not_rep of type_expr * Jkind.Violation.t
| Record_not_rep of type_expr * Jkind.Violation.t
+ | Mutable_var_not_rep of type_expr * Jkind.Violation.t
| Invalid_label_for_src_pos of arg_label
| Nonoptional_call_pos_label of string
| Cannot_stack_allocate of Env.locality_context option
@@ -1163,6 +1170,7 @@ type pattern_variable =
pv_id: Ident.t;
pv_uid: Uid.t;
pv_mode: Value.l;
+ pv_mutable: mutability;
pv_type: type_expr;
pv_loc: Location.t;
pv_as_var: bool;
@@ -1259,13 +1267,32 @@ let maybe_add_pattern_variables_ghost loc_let env pv =
let iter_pattern_variables_type f : pattern_variable list -> unit =
List.iter (fun {pv_type; _} -> f pv_type)
+let iter_pattern_variables_type_mut ~f_immut ~f_mut pvs =
+ List.iter (fun {pv_type; pv_mutable} ->
+ match pv_mutable with
+ | Immutable -> f_immut pv_type
+ | Mutable _ -> f_mut pv_type) pvs
+
let add_pattern_variables ?check ?check_as env pv =
List.fold_right
- (fun {pv_id; pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid}
- env ->
+ (fun {pv_id; pv_mode; pv_type; pv_loc; pv_as_var;
+ pv_mutable; pv_attributes; pv_uid} env ->
let check = if pv_as_var then check_as else check in
+ let kind = match pv_mutable with
+ | Immutable -> Val_reg
+ | Mutable mode ->
+ Val_mut (mutable_mode mode,
+ match
+ (* CR-someday let_mutable: move the sort calculation elsewhere *)
+ Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
+ ~fixed:false env pv_type
+ with
+ | Ok sort -> sort
+ | Error err -> raise(Error(pv_loc, env,
+ Function_type_not_rep(pv_type, err))))
+ in
Env.add_value ?check ~mode:pv_mode pv_id
- {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
+ {val_type = pv_type; val_kind = kind; Types.val_loc = pv_loc;
val_attributes = pv_attributes; val_modalities = Modality.Value.id;
val_zero_alloc = Zero_alloc.default;
val_uid = pv_uid
@@ -1313,7 +1340,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 =
+ mutability 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));
@@ -1347,6 +1374,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 = mutability;
pv_type = ty;
pv_loc = loc;
pv_as_var = is_as_variable;
@@ -1968,7 +1996,9 @@ let type_for_loop_index ~loc ~env ~param =
let pv_id = Ident.create_local txt in
let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
let pv =
- { pv_id; pv_uid; pv_mode=Value.disallow_right pv_mode; pv_type; pv_loc; pv_as_var; pv_attributes }
+ { pv_id; pv_uid; pv_mode=Value.disallow_right pv_mode;
+ pv_mutable=Immutable; pv_type; pv_loc; pv_as_var;
+ pv_attributes }
in
(pv_id, pv_uid), add_pattern_variables ~check ~check_as:check env [pv])
@@ -1989,9 +2019,30 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps =
pv_loc
name
pv_mode
+ Immutable
pv_type
pv_attributes)
+let check_let_mutable (mf : mutable_flag) env ?restriction vbs =
+ match vbs, mf with
+ | vb :: vbs, Mutable -> begin
+ let loc = vb.pvb_pat.ppat_loc in
+ (* If the [let] is [mutable], check:
+ - Let_mutable is enabled
+ - There is only one value binding
+ - The value binding pattern consists only of a variable, possibly
+ with a type/mode constraint
+ - Mutables are not restricted here according to [restriction] *)
+ Language_extension.assert_enabled ~loc Let_mutable ();
+ match restriction, vb.pvb_pat.ppat_desc, vbs with
+ | _, _, _ :: _ -> raise (Error (loc, env, Unexpected_mutable In_group))
+ | Some r, _, _ -> raise (Error (loc, env, Unexpected_mutable r))
+ | None, Ppat_var _, [] -> ()
+ | None, (Ppat_constraint ({ppat_desc=Ppat_var _}, _, _)), [] -> ()
+ | None, _, [] -> raise (Error (loc, env, Illegal_mutable_pat))
+ end
+ | _ -> ()
+;;
(* Type paths *)
@@ -2621,22 +2672,25 @@ let components_have_label (labeled_components : (string option * 'a) list) =
let rec type_pat
: type k . type_pat_state -> k pattern_category ->
no_existentials: existential_restriction option ->
- alloc_mode:expected_pat_mode ->
+ alloc_mode:expected_pat_mode -> mutability:_ ->
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 ~mutability ~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 ~mutability ~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 -> mutability:_ -> penv:_ -> _ ->
+ _ -> k general_pattern
+ = fun tps category ~no_existentials ~alloc_mode ~mutability ~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 ~mutability ~penv
in
let loc = sp.ppat_loc in
let solve_expected (x : pattern) : pattern =
@@ -2652,23 +2706,23 @@ and type_pat_aux
let rp = crp
and rvp x = crp (pure category x)
and rcp x = crp (only_impure category x) in
- let type_pat_array mutability spl pat_attributes =
+ let type_pat_array mut spl pat_attributes =
(* Sharing the code between the two array cases means we're guaranteed to
keep them in sync, at the cost of a worse diff with upstream; it
shouldn't be too bad. We can inline this when we upstream this code and
combine the two array pattern constructors. *)
let ty_elt, arg_sort =
- solve_Ppat_array ~refine:false loc penv mutability expected_ty
+ solve_Ppat_array ~refine:false loc penv mut expected_ty
in
let modalities =
- Typemode.transl_modalities ~maturity:Stable mutability []
+ Typemode.transl_modalities ~maturity:Stable mut []
in
- check_project_mutability ~loc ~env:!!penv mutability alloc_mode.mode;
+ check_project_mutability ~loc ~env:!!penv mut alloc_mode.mode;
let alloc_mode = Modality.Value.Const.apply modalities alloc_mode.mode in
let alloc_mode = simple_pat_mode alloc_mode in
let pl = List.map (fun p -> type_pat ~alloc_mode tps Value p ty_elt) spl in
rvp {
- pat_desc = Tpat_array (mutability, arg_sort, pl);
+ pat_desc = Tpat_array (mut, arg_sort, pl);
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
pat_attributes;
@@ -2826,7 +2880,8 @@ and type_pat_aux
cross_left !!penv expected_ty alloc_mode.mode
in
let id, uid =
- enter_variable tps loc name alloc_mode ty sp.ppat_attributes
+ enter_variable tps loc name alloc_mode mutability ty
+ sp.ppat_attributes
in
rvp {
pat_desc = Tpat_var (id, name, uid, alloc_mode);
@@ -2852,7 +2907,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 mutability
t ~is_module:true sp.ppat_attributes in
rvp {
pat_desc = Tpat_var (id, v, uid, alloc_mode.mode);
@@ -2868,8 +2923,8 @@ and type_pat_aux
let ty_var, mode = solve_Ppat_alias ~mode:alloc_mode.mode !!penv q in
let mode = cross_left !!penv expected_ty mode in
let id, uid =
- enter_variable ~is_as_variable:true tps name.loc name mode ty_var
- sp.ppat_attributes
+ enter_variable ~is_as_variable:true tps name.loc name mode mutability
+ ty_var sp.ppat_attributes
in
rvp { pat_desc = Tpat_alias(q, id, name, uid, mode, ty_var);
pat_loc = loc; pat_extra=[];
@@ -3154,14 +3209,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 ~mutability penv =
+ type_pat tps category ~no_existentials ~mutability ~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 ~mutability:Immutable new_penv spat
+ expected_ty
+ in
let { tps_pattern_variables = pvs;
tps_module_variables = mvs;
tps_pattern_force = forces;
@@ -3169,7 +3227,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 mutability no_existentials env spatl expected_tys allow_modules
=
let tps = create_type_pat_state allow_modules in
let equations_scope = get_current_level () in
@@ -3180,7 +3238,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 ~mutability
+ new_penv pat ty
)
in
let patl = List.map2 type_pat spatl expected_tys in
@@ -3201,7 +3260,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
+ ~mutability:Immutable new_penv spat nv in
if has_variants pat then begin
Parmatch.pressure_variants val_env [pat];
finalize_variants pat;
@@ -3264,7 +3323,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
+ ~mutability:Immutable new_penv spat nv in
List.iter (fun f -> f()) tps.tps_pattern_force;
pat, tps.tps_pattern_variables
@@ -4191,6 +4250,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, _) ->
@@ -4285,7 +4346,9 @@ let rec is_nonexpansive exp =
| Texp_for _
| Texp_send _
| Texp_instvar _
+ | Texp_mutvar _
| Texp_setinstvar _
+ | Texp_setmutvar _
| Texp_override _
| Texp_letexception _
| Texp_letop _
@@ -4520,7 +4583,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
@@ -4739,6 +4802,7 @@ let check_partial_application ~statement exp =
| Texp_field _ | Texp_setfield _ | Texp_array _
| Texp_list_comprehension _ | Texp_array_comprehension _
| Texp_while _ | Texp_for _ | Texp_instvar _
+ | Texp_mutvar _ | Texp_setmutvar _
| Texp_setinstvar _ | Texp_override _ | Texp_assert _
| Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
| Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
@@ -4751,7 +4815,8 @@ let check_partial_application ~statement exp =
check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
| Texp_ifthenelse (_, e1, Some e2) ->
check e1; check e2
- | Texp_let (_, _, e) | Texp_sequence (_, _, e) | Texp_open (_, e)
+ | Texp_let (_, _, e) | Texp_letmutable(_, e)
+ | Texp_sequence (_, _, e) | Texp_open (_, e)
| Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e)
| Texp_exclave e ->
check e
@@ -5707,6 +5772,13 @@ 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}
+ | _ ->
+ fatal_error "Typecore.type_expect_: \
+ bad mutable variable identifier"
+ end
| Val_self (_, _, _, cl_num) ->
let (path, _) =
Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
@@ -5764,7 +5836,7 @@ and type_expect_
exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_let(Nonrecursive,
+ | Pexp_let(Immutable, Nonrecursive,
[{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody)
when turn_let_into_match spat ->
(* TODO: allow non-empty attributes? *)
@@ -5773,8 +5845,23 @@ 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
+ (* CR-someday let_mutable: get mutability mode from parser. For now,
+ * use the default mode [legacy \/ local] *)
+ let mutability = match mutable_flag with
+ | Immutable -> Immutable
+ | Mutable ->
+ Mutable (Mode.Alloc.Comonadic.Const.join
+ Mode.Alloc.Comonadic.Const.legacy
+ { Mode.Alloc.Comonadic.Const.min
+ with areality = Mode.Locality.Const.max })
+ in
+ check_let_mutable mutable_flag env ?restriction spat_sexp_list;
+ let existential_context : existential_restriction =
if rec_flag = Recursive then In_rec
else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
else With_attributes in
@@ -5797,8 +5884,8 @@ and type_expect_
else Modules_rejected
in
let (pat_exp_list, new_env) =
- type_let existential_context env rec_flag spat_sexp_list
- allow_modules
+ type_let existential_context env mutability rec_flag
+ spat_sexp_list allow_modules
in
let body =
type_expect
@@ -5841,8 +5928,17 @@ and type_expect_
(* The "body" component of the scope escape check. *)
unify_exp new_env body (newvar (Jkind.Builtin.any ~why:Dummy_jkind)))
in
+ let exp =
+ match mutable_flag, pat_exp_list with
+ | Immutable, _ -> Texp_let(rec_flag, pat_exp_list, body)
+ | Mutable, [vb] -> Texp_letmutable(vb, body)
+ | Mutable, _ ->
+ (* Unreachable: should be prevented by [check_let_mutable] *)
+ fatal_error "Typecore.type_expect_: \
+ [let mutable] should have exactly one value binding"
+ in
re {
- exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+ exp_desc = exp;
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
@@ -6428,28 +6524,33 @@ and type_expect_
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
- | Pexp_setinstvar (lab, snewval) -> begin
- let (path, mut, cl_num, ty) =
- Env.lookup_instance_variable ~loc lab.txt env
- in
- match mut with
- | Mutable ->
- let newval =
- type_expect env mode_legacy snewval
- (mk_expected (instance ty))
- in
- let (path_self, _) =
- Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
- in
- rue {
- exp_desc = Texp_setinstvar(path_self, path, lab, newval);
- exp_loc = loc; exp_extra = [];
- exp_type = instance Predef.type_unit;
- exp_attributes = sexp.pexp_attributes;
- exp_env = env }
- | _ ->
- raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
- end
+ | Pexp_setvar (lab, snewval) ->
+ let desc =
+ match Env.lookup_settable_variable ~loc lab.txt env with
+ | Instance_variable (path, Mutable, cl_num,ty) ->
+ let newval =
+ type_expect env mode_legacy snewval (mk_expected (instance ty))
+ in
+ let (path_self, _) =
+ Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
+ in
+ Texp_setinstvar(path_self, path, lab, newval)
+ | Instance_variable (_,Immutable,_,_) ->
+ raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
+ | Mutable_variable (id, mode, ty, sort) ->
+ let newval =
+ type_expect env (mode_default mode)
+ snewval (mk_expected (instance ty))
+ in
+ let lid = {txt = id; loc} in
+ Texp_setmutvar(lid, sort, newval)
+ in
+ rue {
+ exp_desc = desc;
+ exp_loc = loc; exp_extra = [];
+ exp_type = instance Predef.type_unit;
+ exp_attributes = sexp.pexp_attributes;
+ exp_env = env }
| Pexp_override lst ->
submode ~loc ~env Value.legacy expected_mode;
let _ =
@@ -9116,7 +9217,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 mutability rec_flag spat_sexp_list allow_modules =
let rec sexp_is_fun sexp =
match sexp.pexp_desc with
| Pexp_function _ -> true
@@ -9157,8 +9258,8 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
in
let (pat_list, _new_env, _force, pvs, _mvs as res) =
with_local_level_if is_recursive (fun () ->
- type_pattern_list Value existential_context env spatl nvs
- allow_modules
+ type_pattern_list Value mutability existential_context env spatl
+ nvs allow_modules
) ~post:(fun (_, _, _, pvs, _) ->
iter_pattern_variables_type generalize pvs)
in
@@ -9281,7 +9382,10 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
(fun (_, pat, _) (exp, _) ->
if maybe_expansive exp then lower_contravariant env pat.pat_type)
mode_pat_typ_list exp_list;
- iter_pattern_variables_type generalize pvs;
+ iter_pattern_variables_type_mut
+ ~f_immut:generalize
+ ~f_mut:(unify_var env (newvar (Jkind.Builtin.any ~why:Dummy_jkind)))
+ pvs;
(* update pattern variable jkind reasons *)
List.iter
(fun pv ->
@@ -9968,6 +10072,7 @@ and type_comprehension_iterator
Value
~no_existentials:In_self_pattern
~alloc_mode:(simple_pat_mode Value.legacy)
+ ~mutability:Immutable
penv
pattern
item_ty
@@ -10072,21 +10177,22 @@ let maybe_check_uniqueness_value_bindings vbl =
(* Typing of toplevel bindings *)
-let type_binding env rec_flag ?force_toplevel spat_sexp_list =
+let type_binding env mutability 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 mutability 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 mutability 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 mutability rec_flag spat_sexp_list
+ Modules_rejected
in
maybe_check_uniqueness_value_bindings pat_exp_list;
(pat_exp_list, new_env)
@@ -10819,6 +10925,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.@]"
@@ -10902,6 +11018,10 @@ let report_error ~loc env =
Location.errorf ~loc
"Only variables are allowed as left-hand side of %a"
Style.inline_code "let rec"
+ | Illegal_mutable_pat ->
+ Location.errorf ~loc
+ "Only variables are allowed as the left-hand side of %a"
+ Style.inline_code "let mutable"
| Illegal_letrec_expr ->
Location.errorf ~loc
"This kind of expression is not allowed as right-hand side of %a"
@@ -11132,6 +11252,11 @@ let report_error ~loc env =
"@[Record expressions must be representable.@]@ %a"
(Jkind.Violation.report_with_offender
~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation
+ | Mutable_var_not_rep (ty, violation) ->
+ Location.errorf ~loc
+ "@[Mutable variables must be representable.@]@ %a"
+ (Jkind.Violation.report_with_offender
+ ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation
| Invalid_label_for_src_pos arg_label ->
Location.errorf ~loc
"A position argument must not be %s."
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 503181e54de..64f25943dd0 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: mutability;
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 -> mutability -> 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 -> mutability -> rec_flag ->
Parsetree.value_binding list ->
Typedtree.value_binding list * Env.t
val type_expression:
@@ -268,6 +273,7 @@ type error =
| Cannot_infer_signature
| Not_a_packed_module of type_expr
| Unexpected_existential of existential_restriction * string
+ | Unexpected_mutable of mutable_restriction
| Invalid_interval
| Invalid_for_loop_index
| Invalid_comprehension_for_range_iterator_index
@@ -290,6 +296,7 @@ type error =
| Float32_literal of string
| Illegal_letrec_pat
| Illegal_letrec_expr
+ | Illegal_mutable_pat
| Illegal_class_expr
| Letop_type_clash of string * Errortrace.unification_error
| Andop_type_clash of string * Errortrace.unification_error
@@ -321,6 +328,7 @@ type error =
| Function_type_not_rep of type_expr * Jkind.Violation.t
| Record_projection_not_rep of type_expr * Jkind.Violation.t
| Record_not_rep of type_expr * Jkind.Violation.t
+ | Mutable_var_not_rep of type_expr * Jkind.Violation.t
| Invalid_label_for_src_pos of arg_label
| Nonoptional_call_pos_label of string
| Cannot_stack_allocate of Env.locality_context option
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 9157a66e932..b840261a7bf 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -215,6 +215,7 @@ and expression_desc =
Path.t * Longident.t loc * Types.value_description * ident_kind * unique_use
| Texp_constant of constant
| Texp_let of rec_flag * value_binding list * expression
+ | Texp_letmutable of value_binding * expression
| Texp_function of
{ params : function_param list;
body : function_body;
@@ -277,7 +278,9 @@ and expression_desc =
| Texp_new of
Path.t * Longident.t loc * Types.class_declaration * apply_position
| Texp_instvar of Path.t * Path.t * string loc
+ | Texp_mutvar of Ident.t loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression
+ | Texp_setmutvar of Ident.t loc * Jkind.sort * expression
| Texp_override of Path.t * (Ident.t * string loc * expression) list
| Texp_letmodule of
Ident.t option * string option loc * Types.module_presence * module_expr *
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index edaa8f8e991..94c7589cc4b 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -322,6 +322,8 @@ and expression_desc =
(** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
*)
+ | Texp_letmutable of value_binding * expression
+ (** let mutable P = E in E' *)
| Texp_function of
{ params : function_param list;
body : function_body;
@@ -481,7 +483,9 @@ and expression_desc =
| Texp_new of
Path.t * Longident.t loc * Types.class_declaration * apply_position
| Texp_instvar of Path.t * Path.t * string loc
+ | Texp_mutvar of Ident.t loc
| Texp_setinstvar of Path.t * Path.t * string loc * expression
+ | Texp_setmutvar of Ident.t loc * Jkind.sort * expression
| Texp_override of Path.t * (Ident.t * string loc * expression) list
| Texp_letmodule of
Ident.t option * string option loc * Types.module_presence * module_expr *
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 132907c3c36..ac9248dc387 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -3101,7 +3101,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr =
Tstr_eval (expr, sort, attrs), [], shape_map, env
| Pstr_value (rec_flag, sdefs) ->
let (defs, newenv) =
- Typecore.type_binding env rec_flag ~force_toplevel sdefs in
+ Typecore.type_binding env Immutable rec_flag ~force_toplevel sdefs in
let defs = match rec_flag with
| Recursive -> Typecore.annotate_recursive_bindings env defs
| Nonrecursive -> defs
diff --git a/typing/types.ml b/typing/types.ml
index 96565dfaf3f..19b91de60e2 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -474,6 +474,12 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
+ | Val_mut of Mode.Value.r * Jkind_types.Sort.t
+ (* Mutable value (let mutable(m0) x = ..)
+ * where m0 is the upper bound of future values
+ *
+ * Note: as of 2025-05, the (m0) syntax does
+ * not exist, so m0 is always [legacy \/ local] *)
| 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 281b864ecd3..a9ed9c1047a 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -649,6 +649,12 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
+ | Val_mut of Mode.Value.r * Jkind_types.Sort.t
+ (* Mutable value (let mutable(m0) x = ..)
+ * where m0 is the upper bound of future values
+ *
+ * Note: as of 2025-05, the (m0) syntax does
+ * not exist, so m0 is always [legacy \/ local] *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of class_signature * self_meths * Ident.t Vars.t * string
diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml
index e6aaf2b9907..1c80bbae77e 100644
--- a/typing/uniqueness_analysis.ml
+++ b/typing/uniqueness_analysis.ml
@@ -2138,6 +2138,13 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t =
check_uniqueness_exp ~overwrite:None (Ienv.extend ienv ext) body
in
UF.seq uf_vbs uf_body
+ | Texp_letmutable (vb, body) ->
+ (* 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
@@ -2325,7 +2332,9 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t =
| Texp_send (e, _, _) -> check_uniqueness_exp ~overwrite:None ienv e
| Texp_new _ -> UF.unused
| Texp_instvar _ -> UF.unused
+ | Texp_mutvar _ -> UF.unused
| Texp_setinstvar (_, _, _, e) -> check_uniqueness_exp ~overwrite:None ienv e
+ | Texp_setmutvar (_, _, e) -> check_uniqueness_exp ~overwrite:None ienv e
| Texp_override (_, ls) ->
UF.pars
(List.map
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 9c4544536a3..114062aeb62 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -493,9 +493,13 @@ let expression sub exp =
Texp_ident (_path, lid, _, _, _) -> Pexp_ident (map_loc sub lid)
| Texp_constant cst -> Pexp_constant (constant cst)
| Texp_let (rec_flag, list, exp) ->
- Pexp_let (rec_flag,
+ Pexp_let (Immutable, rec_flag,
List.map (sub.value_binding sub) list,
sub.expr sub exp)
+ | Texp_letmutable (vb, exp) ->
+ Pexp_let (Mutable, Nonrecursive,
+ [sub.value_binding sub vb],
+ sub.expr sub exp)
| Texp_function { params; body } ->
let body, constraint_ =
match body with
@@ -632,8 +636,15 @@ let expression sub exp =
| Texp_new (_path, lid, _, _) -> Pexp_new (map_loc sub lid)
| Texp_instvar (_, path, name) ->
Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+ | Texp_mutvar id ->
+ Pexp_ident ({loc = sub.location sub id.loc;
+ txt = lident_of_path (Pident id.txt)})
| Texp_setinstvar (_, _path, lid, exp) ->
- Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+ Pexp_setvar (map_loc sub lid, sub.expr sub exp)
+ | Texp_setmutvar(lid, _sort, exp) ->
+ let lid = {loc = sub.location sub lid.loc;
+ txt = Ident.name lid.txt} in
+ Pexp_setvar (lid, sub.expr sub exp)
| Texp_override (_, list) ->
Pexp_override (List.map (fun (_path, lid, exp) ->
(map_loc sub lid, sub.expr sub exp)
diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml
index 25f5cf61ef2..16920ad27f5 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 <bindings> in body : m
*)
value_bindings rec_flag bindings >> expression body
+ | Texp_letmutable (binding,body) ->
+ (*
+ G |- <bindings> : m -| G'
+ G' |- body : m
+ --------------------------------
+ G |- let mutable <bindings> in body : m
+ *)
+ value_bindings Nonrecursive [binding] >> expression body
| Texp_letmodule (x, _, _, mexp, e) ->
module_binding (x, mexp) >> expression e
| Texp_match (e, _, cases, _) ->
@@ -675,6 +690,8 @@ let rec expression : Typedtree.expression -> term_judg =
path pth << Dereference
| Texp_instvar (self_path, pth, _inst_var) ->
join [path self_path << Dereference; path pth]
+ | Texp_mutvar id ->
+ single id.txt << Dereference
| Texp_apply
({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)}, [_, Arg (arg, _)], _,
_, _)
@@ -886,6 +903,13 @@ let rec expression : Typedtree.expression -> term_judg =
path pth << Dereference;
expression e << Dereference;
]
+ | Texp_setmutvar (_id,_sort,e) ->
+ (*
+ G |- e: m[Dereference]
+ ----------------------
+ G |- x <- e: m
+ *)
+ expression e << Dereference
| Texp_letexception ({ext_id}, e) ->
(* G |- e: m
----------------------------
diff --git a/utils/language_extension_kernel.ml b/utils/language_extension_kernel.ml
index 24b0f86a4b9..14b87d103f0 100644
--- a/utils/language_extension_kernel.ml
+++ b/utils/language_extension_kernel.ml
@@ -19,6 +19,7 @@ type _ t =
| Small_numbers : maturity t
| Instances : unit t
| Separability : unit t
+ | Let_mutable : unit t
(* When you update this, update [pair_of_string] below too. *)
let to_string : type a. a t -> string = function
@@ -36,3 +37,4 @@ let to_string : type a. a t -> string = function
| Small_numbers -> "small_numbers"
| Instances -> "instances"
| Separability -> "separability"
+ | Let_mutable -> "let_mutable"
diff --git a/utils/language_extension_kernel.mli b/utils/language_extension_kernel.mli
index 75eb647036e..c78788f1ef3 100644
--- a/utils/language_extension_kernel.mli
+++ b/utils/language_extension_kernel.mli
@@ -30,6 +30,7 @@ type _ t =
| Small_numbers : maturity t
| Instances : unit t
| Separability : unit t
+ | Let_mutable : unit t
(** Print and parse language extensions; parsing is case-insensitive *)
val to_string : _ t -> string
diff --git a/utils/profile_counters_functions.ml b/utils/profile_counters_functions.ml
index dd247d1b4e8..85372d2ad71 100644
--- a/utils/profile_counters_functions.ml
+++ b/utils/profile_counters_functions.ml
@@ -11,7 +11,7 @@ let count_language_extensions typing_input =
| Labeled_tuples ->
Language_extension_kernel.to_string lang_ext
| Mode | Unique | Polymorphic_parameters | Layouts | SIMD | Small_numbers
- | Instances | Overwriting | Separability ->
+ | Instances | Overwriting | Separability | Let_mutable ->
let error_msg =
Format.sprintf "No counters supported for language extension : %s."
(Language_extension_kernel.to_string lang_ext)
From 6f56c27f76ffe785b5bba881e2d6bcabb5767771 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Fri, 30 May 2025 15:12:21 -0400
Subject: [PATCH 02/32] WIP
---
.../let-mutable.md | 17 +++++++-----
typing/env.ml | 26 ++++++++++++++-----
typing/env.mli | 2 +-
3 files changed, 30 insertions(+), 15 deletions(-)
diff --git a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
index a1d19b29ddb..496f9541e74 100644
--- a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
+++ b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
@@ -12,13 +12,7 @@ let triangle n =
total
```
-Mutable `let` declarations may not be recursive, and they may not be used at the
-structure level or in class definitions. The pattern of a mutable `let`
-statement must be a single variable, possibly with a type annotation, e.g. `let
-mutable x, y = ..` is not allowed. Mutable `let` statements must also not use
-`and`s.
-
-Mutable variables must also not escape their scope. For example, you can't
+Mutable variables must not escape their scope. For example, you can't
return a closure that closes over a mutable variable. At the moment, the mode
checker is, sadly, not sophisticated enough to allow some constructions which
are obviously safe. For example, the following code is safe, but rejected by the
@@ -30,3 +24,12 @@ let sum xs =
List.iter xs ~f:(fun x -> total <- total + x);
total
```
+
+
+## Restrictions
+
+Mutable `let` declarations may not be recursive, and they may not be used at the
+structure level or in class definitions. The pattern of a mutable `let`
+statement must be a single variable, possibly with a type annotation, e.g. `let
+mutable x, y = ..` and `let mutable add x y = ..` are not allowed. Mutable `let`
+statements must also not use `and`s.
diff --git a/typing/env.ml b/typing/env.ml
index b7fb685309d..b79282a8451 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -806,6 +806,7 @@ type lookup_error =
| No_unboxed_version of Longident.t * type_declaration
| Error_from_persistent_env of Persistent_env.error
| Mutable_value_used_in_closure of string
+ | Mutable_value_used_in_escape of string
type error =
| Missing_module of Location.t * Path.t * Path.t
@@ -3307,20 +3308,26 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks =
let unwalk_locks ~errors:_ ~loc:_ ~env:_ ~item:_ ~lid:_ mode _ty _locks =
mode
-(** Would this set of locks prevent a mutable variable from being used?
+(** Which lock, if any, blocks mutable variables from being used?
The current implementation is too restrictive: Any [Closure_lock] will
block a mutable variable, even if the closure does not leave the mutable
variable's scope *)
-let blocks_mutable_variables locks =
- List.exists (function
- | Closure_lock _ | Escape_lock _ | Share_lock _ -> true
- | Region_lock | Exclave_lock | Unboxed_lock -> false) locks
+let lock_blocking_mutable_variables locks =
+ List.find_opt (function
+ (* CR jrayman for zqian: is this correct, specifically for share locks? *)
+ | Closure_lock _ | Escape_lock _ -> true
+ | Share_lock _ | Region_lock | Exclave_lock | Unboxed_lock -> false) 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 blocks_mutable_variables locks ->
- may_lookup_error errors loc env (Mutable_value_used_in_closure name)
+ when lock_blocking_mutable_variables locks |> Option.is_some ->
+ may_lookup_error errors loc env
+ (match lock_blocking_mutable_variables locks |> Option.get with
+ | Closure_lock _ -> Mutable_value_used_in_closure name
+ | Escape_lock _ -> Mutable_value_used_in_escape name
+ | _ -> assert false
+ (* See definition of [lock_blocking_mutable_variables] *))
| Ok (path, locks, Val_bound vda) ->
use_value ~use ~loc path vda;
path, locks, vda
@@ -4704,6 +4711,11 @@ let report_lookup_error _loc env ppf = function
"@[The variable %s is mutable, so cannot be used \
inside a closure that might escape@]"
name
+ | Mutable_value_used_in_escape name ->
+ fprintf ppf
+ "@[The variable %s is mutable, so it may not cross an \
+ escape lock@]"
+ name
let report_error ppf = function
| Missing_module(_, path1, path2) ->
diff --git a/typing/env.mli b/typing/env.mli
index ebbfd20b028..246b8613a46 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -258,7 +258,7 @@ type lookup_error =
| No_unboxed_version of Longident.t * type_declaration
| 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_escape of string (* jra: write test for this *)
val lookup_error: Location.t -> t -> lookup_error -> 'a
From 21945a4b90b9de8ba82304d1cc7f14711f90892c Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Fri, 30 May 2025 16:40:16 -0400
Subject: [PATCH 03/32] WIP
---
testsuite/tests/typing-layouts/let_mutable.ml | 64 +++++++++++++++++++
.../typing-layouts/let_mutable.reference | 4 ++
testsuite/tests/typing-local/let_mutable.ml | 2 +-
3 files changed, 69 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/typing-layouts/let_mutable.ml
create mode 100644 testsuite/tests/typing-layouts/let_mutable.reference
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
new file mode 100644
index 00000000000..0226e6ead42
--- /dev/null
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -0,0 +1,64 @@
+(* TEST
+ reference = "${test_source_directory}/let_mutable.reference";
+ include stdlib_upstream_compatible;
+ flambda2;
+ {
+ flags = "-extension let_mutable";
+ native;
+ }{
+ flags = "-extension let_mutable";
+ bytecode;
+ }{
+ flags = "-extension layouts_alpha -extension let_mutable";
+ native;
+ }{
+ flags = "-extension layouts_alpha -extension let_mutable";
+ bytecode;
+ }{
+ flags = "-extension layouts_beta -extension let_mutable";
+ native;
+ }{
+ flags = "-extension layouts_beta -extension let_mutable";
+ bytecode;
+ }*)
+
+open Stdlib_upstream_compatible
+
+let triangle_f64 n =
+ let mutable sum = #0.0 in
+ for i = 1 to n do
+ sum <- Float_u.add sum (Float_u.of_int i)
+ done;
+ sum
+
+let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float_u.to_float)
+
+
+let triangle_f32 n =
+ let mutable sum = #0.0s in
+ for i = 1 to n do
+ sum <- Float32_u.add sum (Float32_u.of_int i)
+ done;
+ sum
+
+let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float32_u.to_float)
+
+
+let triangle_i32 n =
+ let mutable sum = #0l in
+ for i = 1 to n do
+ sum <- Int32_u.add sum (Int32_u.of_int i)
+ done;
+ sum
+
+let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int)
+
+
+let triangle_i64 n =
+ let mutable sum = #0L in
+ for i = 1 to n do
+ sum <- Int64_u.add sum (Int64_u.of_int i)
+ done;
+ sum
+
+let () = Printf.printf "%d\n" (triangle_i64 10 |> Int64_u.to_int)
diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference
new file mode 100644
index 00000000000..ac9dad34ae8
--- /dev/null
+++ b/testsuite/tests/typing-layouts/let_mutable.reference
@@ -0,0 +1,4 @@
+55.00
+55.00
+55
+55
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index d52679ef46b..d541878fdf3 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -306,7 +306,7 @@ val x_14 : int = 32
|}]
(* Test 15: mutable unboxed floats *)
-let r_15 =
+let r_15 e
let open Stdlib_upstream_compatible.Float_u in
let mutable r = #256.0 in
for i = 1 to 10 do
From 9ec4e0fdf95bbd900437749111f659d824d21e8f Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 2 Jun 2025 11:10:05 -0400
Subject: [PATCH 04/32] WIP
---
parsing/ast_invariants.ml | 5 +++++
parsing/parser.mly | 1 -
parsing/parsetree.mli | 8 ++++++--
3 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
index 8108a81efd8..ce23e1f6bbb 100644
--- a/parsing/ast_invariants.ml
+++ b/parsing/ast_invariants.ml
@@ -27,6 +27,8 @@ let short_closed_tuple_pat loc =
err loc "Closed tuple patterns must have at least 2 components."
let no_args loc = err loc "Function application with no argument."
let empty_let loc = err loc "Let with no bindings."
+let mutable_rec_let loc = err loc "Mutable let binding cannot be recursive."
+let multiple_mutable_let loc = err loc "Mutable let must have only one binding."
let empty_type loc = err loc "Type declarations cannot be empty."
let complex_id loc = err loc "Functor application not allowed here."
let module_type_substitution_missing_rhs loc =
@@ -119,6 +121,9 @@ let iterator =
| Pexp_record ([], _) -> empty_record loc
| Pexp_apply (_, []) -> no_args loc
| Pexp_let (_, _, [], _) -> empty_let loc
+ | Pexp_let (Mutable, Recursive, _, _) -> mutable_rec_let loc
+ | Pexp_let (Mutable, _, _ :: _, _) -> multiple_mutable_let loc
+ (* jra: test previous two invariants *)
| Pexp_ident id
| Pexp_construct (id, _)
| Pexp_field (_, id)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index c99a3d9e732..6b3e0ea35f2 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -726,7 +726,6 @@ let expr_of_let_bindings ~loc lbs body =
match lbs.lbs_mutable, ghost_fun_binding_loc lbs.lbs_bindings with
| Mutable, Some loc ->
raise (Syntaxerr.Error
- (* jra: rename error *)
(Syntaxerr.Let_mutable_not_allowed_with_function_bindings loc))
| _ ->
mkexp_attrs ~loc
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 655ecd47d06..d855e06b60d 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -376,8 +376,12 @@ and expression_desc =
- [let mutable P1 = E1 in E]
when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}
and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}.
- Invariant: If [mut = Mutable] then [n = 1] and [rec = Nonrecursive]
- *)
+ Invariant: If [mut = Mutable] then [n = 1] and [rec = Nonrecursive] *)
+
+ (* CR jrayman: The parser forbids the sugared function syntax with
+ * [mut = Mutable] (e.g. [let mutable f x y = ..]) by checking if the RHS
+ * of the binding is a ghost function expression. Does this method prevent
+ * PPXs from generating mutable function bindings? *)
| Pexp_function of
function_param list * function_constraint * function_body
(** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct
From 44f9889221148bfd334f22d35ed978cbe8bedb36 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 2 Jun 2025 11:24:39 -0400
Subject: [PATCH 05/32] WIP
---
testsuite/tests/typing-layouts/let_mutable.ml | 29 +++++++++++++++----
.../typing-layouts/let_mutable.reference | 1 +
2 files changed, 25 insertions(+), 5 deletions(-)
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index 0226e6ead42..48eeddefbc0 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -41,7 +41,17 @@ let triangle_f32 n =
done;
sum
-let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float32_u.to_float)
+let () = Printf.printf "%.2f\n" (triangle_f32 10 |> Float32_u.to_float)
+
+
+let triangle_i64 n =
+ let mutable sum = #0L in
+ for i = 1 to n do
+ sum <- Int64_u.add sum (Int64_u.of_int i)
+ done;
+ sum
+
+let () = Printf.printf "%d\n" (triangle_i64 10 |> Int64_u.to_int)
let triangle_i32 n =
@@ -54,11 +64,20 @@ let triangle_i32 n =
let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int)
-let triangle_i64 n =
- let mutable sum = #0L in
+(* jra: how do you create a vec128? *)
+
+let triangle_i64_i32_f64 n =
+ let mutable sum = #(#0L, #(#0l, #0.)) in
for i = 1 to n do
- sum <- Int64_u.add sum (Int64_u.of_int i)
+ let #(a, #(b, c)) = sum in
+ sum <- #(Int64_u.add a (Int64_u.of_int i),
+ #(Int32_u.add b (Int32_u.of_int i),
+ Float_u.add c (Float_u.of_int i)))
done;
sum
-let () = Printf.printf "%d\n" (triangle_i64 10 |> Int64_u.to_int)
+let () =
+ let #(a, #(b, c)) = triangle_i64_i32_f64 10 in
+ Printf.printf "%d %d %.2f\n" (Int64_u.to_int a)
+ (Int32_u.to_int b)
+ (Float_u.to_float c)
diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference
index ac9dad34ae8..017dceb4972 100644
--- a/testsuite/tests/typing-layouts/let_mutable.reference
+++ b/testsuite/tests/typing-layouts/let_mutable.reference
@@ -2,3 +2,4 @@
55.00
55
55
+55 55 55.00
From bfd8d45fa98b76b0d2c6c36212cdc37719ce9fbd Mon Sep 17 00:00:00 2001
From: Zesen Qian <github@riaqn.org>
Date: Mon, 2 Jun 2025 17:13:58 +0100
Subject: [PATCH 06/32] improve mode checking
---
typing/env.ml | 91 +++++++++++++++++++++++++++---------------------
typing/env.mli | 5 +--
typing/types.ml | 5 ---
typing/types.mli | 13 ++++---
4 files changed, 63 insertions(+), 51 deletions(-)
diff --git a/typing/env.ml b/typing/env.ml
index b79282a8451..717af7d550c 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -805,8 +805,8 @@ type lookup_error =
| Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t
| No_unboxed_version of Longident.t * type_declaration
| Error_from_persistent_env of Persistent_env.error
- | Mutable_value_used_in_closure of string
- | Mutable_value_used_in_escape of string
+ | Mutable_value_used_in_closure of
+ [`Escape of escaping_context | `Shared of shared_context | `Closure]
type error =
| Missing_module of Location.t * Path.t * Path.t
@@ -3304,31 +3304,47 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks =
vmode
) vmode locks
-(** jra: write documentation *)
-let unwalk_locks ~errors:_ ~loc:_ ~env:_ ~item:_ ~lid:_ mode _ty _locks =
- mode
-
-(** Which lock, if any, blocks mutable variables from being used?
- The current implementation is too restrictive: Any [Closure_lock] will
- block a mutable variable, even if the closure does not leave the mutable
- variable's scope *)
-let lock_blocking_mutable_variables locks =
- List.find_opt (function
- (* CR jrayman for zqian: is this correct, specifically for share locks? *)
- | Closure_lock _ | Escape_lock _ -> true
- | Share_lock _ | Region_lock | Exclave_lock | Unboxed_lock -> false) locks
+(** Take the parameter of [mutable(m0)] at declaration site, *)
+let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks =
+ List.fold_left
+ (fun (mode : Mode.Value.r) lock ->
+ match lock with
+ | Region_lock ->
+ (* If [m0] is [global], then inside the region we require new values
+ to be [global]. If [m0] is [local], morally inside the region we can
+ require new values to be [regional]. However, GC doesn't support
+ backward pointers inside a single stack frame. So we just require
+ new values to be [global].
+ *)
+ Mode.Value.meet
+ [mode;
+ Mode.Value.max_with (Comonadic Areality) (Mode.Regionality.global)]
+ | Exclave_lock ->
+ (* If [m0] is [global], then inside the exclave we require new values
+ to be [global]. If [m0] is [local], then we require the new values to
+ be [local]. *)
+ mode
+ | Escape_lock ctx ->
+ may_lookup_error errors loc env (Mutable_value_used_in_closure (`Escape ctx))
+ | Share_lock ctx ->
+ may_lookup_error errors loc env (Mutable_value_used_in_closure (`Shared ctx))
+ | Closure_lock _ ->
+ may_lookup_error errors loc env (Mutable_value_used_in_closure `Closure)
+ | Unboxed_lock -> mode
+ ) mode locks
let lookup_ident_value ~errors ~use ~loc name env =
match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with
- | Ok (_, locks, Val_bound {vda_description={val_kind=Val_mut _}})
- when lock_blocking_mutable_variables locks |> Option.is_some ->
- may_lookup_error errors loc env
- (match lock_blocking_mutable_variables locks |> Option.get with
- | Closure_lock _ -> Mutable_value_used_in_closure name
- | Escape_lock _ -> Mutable_value_used_in_escape name
- | _ -> assert false
- (* See definition of [lock_blocking_mutable_variables] *))
| Ok (path, locks, Val_bound vda) ->
+ let vda =
+ match vda with
+ | {vda_description={val_kind=Val_mut (m0, sort); _}; _} ->
+ let m0 = walk_locks_for_mutable_mode ~errors ~loc ~env m0 locks in
+ let val_kind = Val_mut (m0, sort) in
+ let vda_description = {vda.vda_description with val_kind} in
+ {vda with vda_description}
+ | _ -> vda
+ in
use_value ~use ~loc path vda;
path, locks, vda
| Ok (_, _, Val_unbound reason) ->
@@ -4076,15 +4092,12 @@ 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(mode_restriction, sort), Pident id ->
+ | Val_mut(m0, sort), Pident id ->
let val_type = Subst.Lazy.force_type_expr desc.val_type in
let mode =
- unwalk_locks
- ~errors:true ~loc ~env ~item:Value
- ~lid:(Lident "")
- mode_restriction
- val_type
- locks
+ walk_locks_for_mutable_mode
+ ~errors:true ~loc ~env
+ m0 locks
in
use_value ~use ~loc path vda;
Mutable_variable (id, mode, val_type, sort)
@@ -4706,16 +4719,16 @@ let report_lookup_error _loc env ppf = function
end
| Error_from_persistent_env err ->
Persistent_env.report_error ppf err
- | Mutable_value_used_in_closure name ->
- fprintf ppf
- "@[The variable %s is mutable, so cannot be used \
- inside a closure that might escape@]"
- name
- | Mutable_value_used_in_escape name ->
+ | Mutable_value_used_in_closure ctx ->
+ let ctx =
+ match ctx with
+ | `Escape ctx -> string_of_escaping_context ctx
+ | `Shared ctx -> string_of_shared_context ctx
+ | `Closure -> "closure"
+ in
fprintf ppf
- "@[The variable %s is mutable, so it may not cross an \
- escape lock@]"
- name
+ "@[Mutable variable cannot be used \
+ inside a %s.@]" ctx
let report_error ppf = function
| Missing_module(_, path1, path2) ->
diff --git a/typing/env.mli b/typing/env.mli
index 246b8613a46..6c97e85facf 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -257,8 +257,9 @@ type lookup_error =
| Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t
| No_unboxed_version of Longident.t * type_declaration
| Error_from_persistent_env of Persistent_env.error
- | Mutable_value_used_in_closure of string
- | Mutable_value_used_in_escape of string (* jra: write test for this *)
+ | Mutable_value_used_in_closure of
+ [`Escape of escaping_context | `Shared of shared_context | `Closure]
+
val lookup_error: Location.t -> t -> lookup_error -> 'a
diff --git a/typing/types.ml b/typing/types.ml
index 19b91de60e2..32962ed2528 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -475,11 +475,6 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
| Val_mut of Mode.Value.r * Jkind_types.Sort.t
- (* Mutable value (let mutable(m0) x = ..)
- * where m0 is the upper bound of future values
- *
- * Note: as of 2025-05, the (m0) syntax does
- * not exist, so m0 is always [legacy \/ local] *)
| 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 a9ed9c1047a..7f0b57afa07 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -650,11 +650,14 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
| Val_mut of Mode.Value.r * Jkind_types.Sort.t
- (* Mutable value (let mutable(m0) x = ..)
- * where m0 is the upper bound of future values
- *
- * Note: as of 2025-05, the (m0) syntax does
- * not exist, so m0 is always [legacy \/ local] *)
+ (** Mutable value, declared as [let mutable(m0) x = ..]. The mode returned
+ here is [m0] adjusted for regions, suitable to be used as the expected
+ mode of the new content.
+
+ Currently, the syntax is not supported and [m0] is fixed to be [local,
+ legacy]. After adjusting for regions, the mode here could be [global,
+ legacy].
+ *)
| 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
From d1c6846fe0de4b628968793a1ecefaa4b6f6e897 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 2 Jun 2025 16:32:52 -0400
Subject: [PATCH 07/32] Fix typos
---
testsuite/tests/typing-local/let_mutable.ml | 2 +-
typing/env.ml | 3 +--
2 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index d541878fdf3..d52679ef46b 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -306,7 +306,7 @@ val x_14 : int = 32
|}]
(* Test 15: mutable unboxed floats *)
-let r_15 e
+let r_15 =
let open Stdlib_upstream_compatible.Float_u in
let mutable r = #256.0 in
for i = 1 to 10 do
diff --git a/typing/env.ml b/typing/env.ml
index 717af7d550c..aa48a528847 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -4727,8 +4727,7 @@ let report_lookup_error _loc env ppf = function
| `Closure -> "closure"
in
fprintf ppf
- "@[Mutable variable cannot be used \
- inside a %s.@]" ctx
+ "@[Mutable variable cannot be used inside %s.@]" ctx
let report_error ppf = function
| Missing_module(_, path1, path2) ->
From b13516c1de8d987734fbe2e5a66e459bb5ececa8 Mon Sep 17 00:00:00 2001
From: Zesen Qian <github@riaqn.org>
Date: Tue, 3 Jun 2025 10:24:36 +0100
Subject: [PATCH 08/32] fixes
---
parsing/ast_invariants.ml | 3 ++-
testsuite/tests/ast-invariants/test.reference | 9 ++++++++
testsuite/tests/typing-local/let_mutable.ml | 23 +++++++++++++------
typing/env.ml | 13 ++++-------
typing/env.mli | 1 -
typing/typecore.ml | 8 +++----
6 files changed, 35 insertions(+), 22 deletions(-)
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
index ce23e1f6bbb..26324c01b7e 100644
--- a/parsing/ast_invariants.ml
+++ b/parsing/ast_invariants.ml
@@ -122,7 +122,8 @@ let iterator =
| Pexp_apply (_, []) -> no_args loc
| Pexp_let (_, _, [], _) -> empty_let loc
| Pexp_let (Mutable, Recursive, _, _) -> mutable_rec_let loc
- | Pexp_let (Mutable, _, _ :: _, _) -> multiple_mutable_let loc
+ | Pexp_let (Mutable, _, l, _) when List.length l > 1 ->
+ multiple_mutable_let loc
(* jra: test previous two invariants *)
| Pexp_ident id
| Pexp_construct (id, _)
diff --git a/testsuite/tests/ast-invariants/test.reference b/testsuite/tests/ast-invariants/test.reference
index e69de29bb2d..85aa6f6cd8f 100644
--- a/testsuite/tests/ast-invariants/test.reference
+++ b/testsuite/tests/ast-invariants/test.reference
@@ -0,0 +1,9 @@
+File "/home/zqian/local/repos/let-mutable/_runtest/testsuite/tests/typing-local/let_mutable.ml", lines 200-206, characters 2-15:
+200 | ..let mutable x = []
+201 | and z = 3
+202 | in
+203 | x <- z :: x;
+204 | match x with
+205 | | [] -> 0
+206 | | z :: _ -> z
+Error: broken invariant in parsetree: Mutable let must have only one binding.
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index d52679ef46b..a29ce4423b0 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -33,7 +33,7 @@ let foo2 y =
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
+Error: Mutable variable cannot be used inside closure.
|}]
(* Test 3: Rejected for same reason as test 2, but this one is actually safe and
@@ -50,7 +50,7 @@ let foo3 y =
Line 5, characters 11-12:
5 | | 0 -> x
^
-Error: The variable x is mutable, so cannot be used inside a closure that might escape
+Error: Mutable variable cannot be used inside closure.
|}]
(* Test 4: Disallowed interactions with locals *)
@@ -87,7 +87,7 @@ let foo4_2 y = (* Can't sneak local out of non-local for loop body region *)
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
+Error: Mutable variable cannot be used inside closure.
|}]
@@ -189,10 +189,14 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
done; x
[%%expect{|
-val foo5_1 : 'a -> 'a = <fun>
-val foo5_2 : int -> int = <fun>
-val foo5_3 : int -> int = <fun>
-val foo5_4 : int -> int = <fun>
+Line 4, characters 16-17:
+4 | x <- (local_ (y :: x));
+ ^
+Error: This value is used here, but it has already been used as unique:
+Line 3, characters 16-17:
+3 | x <- (local_ (y :: x));
+ ^
+
|}]
(* Test 6: let mutable ... and ... is illegal *)
@@ -291,6 +295,11 @@ let x_13 =
!y
;;
[%%expect{|
+val reset_ref : int ref @ unique -> unit = <fun>
+Line 6, characters 7-8:
+6 | x <- y;
+ ^
+Error: This value is "aliased" but expected to be "unique".
|}]
(* Test 14: mutable functions *)
diff --git a/typing/env.ml b/typing/env.ml
index aa48a528847..d6790c1d521 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -322,7 +322,6 @@ type shared_context =
| For_loop
| While_loop
| Letop
- | Closure
| Comprehension
| Class
| Module
@@ -3324,10 +3323,12 @@ let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks =
to be [global]. If [m0] is [local], then we require the new values to
be [local]. *)
mode
- | Escape_lock ctx ->
+ | Escape_lock (Letop | Probe | Class | Module as ctx) ->
may_lookup_error errors loc env (Mutable_value_used_in_closure (`Escape ctx))
- | Share_lock ctx ->
+ | Share_lock (Letop | Probe | Class | Module as ctx) ->
may_lookup_error errors loc env (Mutable_value_used_in_closure (`Shared ctx))
+ | Share_lock (For_loop | While_loop | Comprehension) ->
+ mode
| Closure_lock _ ->
may_lookup_error errors loc env (Mutable_value_used_in_closure `Closure)
| Unboxed_lock -> mode
@@ -4432,7 +4433,6 @@ let string_of_shared_context : shared_context -> string =
| For_loop -> "a for loop"
| While_loop -> "a while loop"
| Letop -> "a letop"
- | Closure -> "a closure that is not once"
| Comprehension -> "a comprehension"
| Class -> "a class"
| Module -> "a module"
@@ -4459,11 +4459,6 @@ let sharedness_hint ppf : shared_context -> _ = function
Format.fprintf ppf
"@[Hint: This identifier cannot be used uniquely,@ \
because it is defined in a class.@]"
- | Closure ->
- Format.fprintf ppf
- "@[Hint: This identifier was defined outside of the current closure.@ \
- Either this closure has to be once, or the identifier can be used only@ \
- as aliased.@]"
| Module ->
Format.fprintf ppf
"@[Hint: This identifier cannot be used uniquely,@ \
diff --git a/typing/env.mli b/typing/env.mli
index 6c97e85facf..620d4c34fc2 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -202,7 +202,6 @@ type shared_context =
| For_loop
| While_loop
| Letop
- | Closure
| Comprehension
| Class
| Module
diff --git a/typing/typecore.ml b/typing/typecore.ml
index b8870e79d8c..190e9cf4980 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -5855,10 +5855,10 @@ and type_expect_
let mutability = match mutable_flag with
| Immutable -> Immutable
| Mutable ->
- Mutable (Mode.Alloc.Comonadic.Const.join
- Mode.Alloc.Comonadic.Const.legacy
- { Mode.Alloc.Comonadic.Const.min
- with areality = Mode.Locality.Const.max })
+ Mutable
+ { Mode.Alloc.Comonadic.Const.legacy with
+ areality = Mode.Locality.Const.max;
+ yielding = Mode.Yielding.Const.max }
in
check_let_mutable mutable_flag env ?restriction spat_sexp_list;
let existential_context : existential_restriction =
From 58e0a8a11dd49044e6e93157c36c6dd52c38f858 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 3 Jun 2025 14:34:13 -0400
Subject: [PATCH 09/32] WIP
---
parsing/ast_invariants.ml | 2 +-
testsuite/tests/typing-layouts/let_mutable.ml | 2 +-
testsuite/tests/typing-local/let_mutable.ml | 59 ++++++++++++++-----
typing/typecore.ml | 18 +++---
typing/typemode.ml | 16 ++---
typing/typemode.mli | 2 +
typing/uniqueness_analysis.ml | 2 +-
7 files changed, 70 insertions(+), 31 deletions(-)
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
index 26324c01b7e..ccbfa4d4584 100644
--- a/parsing/ast_invariants.ml
+++ b/parsing/ast_invariants.ml
@@ -124,7 +124,7 @@ let iterator =
| Pexp_let (Mutable, Recursive, _, _) -> mutable_rec_let loc
| Pexp_let (Mutable, _, l, _) when List.length l > 1 ->
multiple_mutable_let loc
- (* jra: test previous two invariants *)
+ (* CR jrayman: test previous two invariants *)
| Pexp_ident id
| Pexp_construct (id, _)
| Pexp_field (_, id)
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index 48eeddefbc0..8429657de2b 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -64,7 +64,7 @@ let triangle_i32 n =
let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int)
-(* jra: how do you create a vec128? *)
+(* CR jrayman: how do you create a vec128? *)
let triangle_i64_i32_f64 n =
let mutable sum = #(#0L, #(#0l, #0.)) in
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index a29ce4423b0..31c4e1d12e0 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -3,7 +3,7 @@
include stdlib_upstream_compatible;
expect; *)
-(* Test 1: basic usage in a for loop *)
+(* Test 1.1: basic usage in a for loop *)
let foo1 y =
let mutable x = y in
for i = 1 to 10 do
@@ -18,6 +18,18 @@ let () = assert (Int.equal (foo1 42) 97)
val foo1 : int -> int = <fun>
|}]
+(* Test 1.2: basic usage with a nested record *)
+type t_1_2 = { str_1_2 : string ref }
+let x_1_2 =
+ let mutable x = { str_1_2 = ref "Hi" } in
+ x <- { str_1_2 = ref "Bye" };
+ x
+[%%expect{|
+type t_1_2 = { str_1_2 : string ref; }
+val x_1_2 : t_1_2 = {str_1_2 = {contents = "Bye"}}
+|}]
+
+
(* Test 2: Reject use of mutable in closure. *)
let foo2 y =
let mutable x = y in
@@ -119,6 +131,7 @@ Line 3, characters 13-29:
Error: This value escapes its region.
|}]
+(* exclave_ closes one region, not two *)
let foo4_5 y =
let mutable x = [] in
for i = 1 to y do
@@ -189,14 +202,10 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
done; x
[%%expect{|
-Line 4, characters 16-17:
-4 | x <- (local_ (y :: x));
- ^
-Error: This value is used here, but it has already been used as unique:
-Line 3, characters 16-17:
-3 | x <- (local_ (y :: x));
- ^
-
+val foo5_1 : 'a -> 'a = <fun>
+val foo5_2 : int -> int = <fun>
+val foo5_3 : int -> int = <fun>
+val foo5_4 : int -> int = <fun>
|}]
(* Test 6: let mutable ... and ... is illegal *)
@@ -284,10 +293,9 @@ type t_12 = Foo_12 of int
val y_12 : t_12 = Foo_12 42
|}]
-(* Test 13: modes? *)
+(* Test 13.1: Can't put aliased in unique mutable variable *)
let reset_ref (x @ unique) = x := 0;;
-
-let x_13 =
+let x_13_1 =
let y = ref 3 in
let mutable x @ unique = { contents = 1 } in
x <- y;
@@ -296,12 +304,35 @@ let x_13 =
;;
[%%expect{|
val reset_ref : int ref @ unique -> unit = <fun>
-Line 6, characters 7-8:
-6 | x <- y;
+Line 5, characters 7-8:
+5 | x <- y;
^
Error: This value is "aliased" but expected to be "unique".
|}]
+(* Test 13.2: Unique mutable variable *)
+let x_13_2 =
+ let mutable x @ unique = { contents = 1 } in
+ reset_ref x;
+ !x
+;;
+[%%expect{|
+val x_13_2 : int = 0
+|}]
+
+(* Test 13.3: Can't put a global in a local record *)
+let x_13_3 = ref 0
+let y_13_3 =
+ let mutable x @ local = ref (ref 0) in
+ x := x_13_3;
+ x <- ref x_13_3;
+ !x
+[%%expect{|
+val x_13_3 : int ref = {contents = 0}
+
+Error: This value is "global" bet expected to be "local".
+|}]
+
(* Test 14: mutable functions *)
let x_14 =
let mutable f = fun x -> 2*x in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 190e9cf4980..6b77d788925 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1281,7 +1281,11 @@ let add_pattern_variables ?check ?check_as env pv =
let kind = match pv_mutable with
| Immutable -> Val_reg
| Mutable mode ->
- Val_mut (mutable_mode mode,
+ let modalities =
+ Typemode.transl_modalities ~maturity:Stable
+ ~for_mutable_variable:true pv_mutable []
+ in
+ Val_mut (mutable_mode mode |> Modality.Value.Const.apply modalities,
match
(* CR-someday let_mutable: move the sort calculation elsewhere *)
Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
@@ -1289,7 +1293,7 @@ let add_pattern_variables ?check ?check_as env pv =
with
| Ok sort -> sort
| Error err -> raise(Error(pv_loc, env,
- Function_type_not_rep(pv_type, err))))
+ Mutable_var_not_rep(pv_type, err))))
in
Env.add_value ?check ~mode:pv_mode pv_id
{val_type = pv_type; val_kind = kind; Types.val_loc = pv_loc;
@@ -2706,23 +2710,23 @@ and type_pat_aux
let rp = crp
and rvp x = crp (pure category x)
and rcp x = crp (only_impure category x) in
- let type_pat_array mut spl pat_attributes =
+ let type_pat_array mutability spl pat_attributes =
(* Sharing the code between the two array cases means we're guaranteed to
keep them in sync, at the cost of a worse diff with upstream; it
shouldn't be too bad. We can inline this when we upstream this code and
combine the two array pattern constructors. *)
let ty_elt, arg_sort =
- solve_Ppat_array ~refine:false loc penv mut expected_ty
+ solve_Ppat_array ~refine:false loc penv mutability expected_ty
in
let modalities =
- Typemode.transl_modalities ~maturity:Stable mut []
+ Typemode.transl_modalities ~maturity:Stable mutability []
in
- check_project_mutability ~loc ~env:!!penv mut alloc_mode.mode;
+ check_project_mutability ~loc ~env:!!penv mutability alloc_mode.mode;
let alloc_mode = Modality.Value.Const.apply modalities alloc_mode.mode in
let alloc_mode = simple_pat_mode alloc_mode in
let pl = List.map (fun p -> type_pat ~alloc_mode tps Value p ty_elt) spl in
rvp {
- pat_desc = Tpat_array (mut, arg_sort, pl);
+ pat_desc = Tpat_array (mutability, arg_sort, pl);
pat_loc = loc; pat_extra=[];
pat_type = instance expected_ty;
pat_attributes;
diff --git a/typing/typemode.ml b/typing/typemode.ml
index fbf2f546040..d2a901aa361 100644
--- a/typing/typemode.ml
+++ b/typing/typemode.ml
@@ -465,7 +465,7 @@ let untransl_modality (a : Modality.t) : Parsetree.modality loc =
removed. The implications on the monadic axes will stay. Implied modalities
can be overriden. *)
(* CR zqian: decouple mutable and comonadic modalities *)
-let mutable_implied_modalities (mut : Types.mutability) =
+let mutable_implied_modalities ~for_mutable_variable (mut : Types.mutability) =
let comonadic : Modality.t list =
[ Atom (Comonadic Areality, Meet_with Regionality.Const.legacy);
Atom (Comonadic Linearity, Meet_with Linearity.Const.legacy);
@@ -478,10 +478,12 @@ let mutable_implied_modalities (mut : Types.mutability) =
Atom (Monadic Contention, Join_with Contention.Const.legacy);
Atom (Monadic Visibility, Join_with Visibility.Const.legacy) ]
in
- match mut with Immutable -> [] | Mutable _ -> monadic @ comonadic
+ match mut with
+ | Immutable -> []
+ | Mutable _ -> if for_mutable_variable then monadic else monadic @ comonadic
-let mutable_implied_modalities (mut : Types.mutability) =
- let l = mutable_implied_modalities mut in
+let mutable_implied_modalities ~for_mutable_variable (mut : Types.mutability) =
+ let l = mutable_implied_modalities ~for_mutable_variable mut in
List.fold_left
(fun t (Modality.Atom (ax, a)) -> Modality.Value.Const.set ax a t)
Modality.Value.Const.id l
@@ -516,7 +518,7 @@ let implied_modalities (Atom (ax, a) : Modality.t) : Modality.t list =
| _ -> []
let least_modalities_implying mut (t : Modality.Value.Const.t) =
- let baseline = mutable_implied_modalities mut in
+ let baseline = mutable_implied_modalities ~for_mutable_variable:false mut in
let annotated = Modality.Value.Const.(diff baseline t) in
let implied = List.concat_map implied_modalities annotated in
let exclude_implied =
@@ -559,8 +561,8 @@ let sort_dedup_modalities ~warn l =
in
l |> List.stable_sort compare |> dedup ~on_dup |> List.map fst
-let transl_modalities ~maturity mut modalities =
- let mut_modalities = mutable_implied_modalities mut in
+let transl_modalities ~maturity ?(for_mutable_variable=false) mut modalities =
+ let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable in
let modalities = List.map (transl_modality ~maturity) modalities in
(* axes listed in the order of implication. *)
let modalities = sort_dedup_modalities ~warn:true modalities in
diff --git a/typing/typemode.mli b/typing/typemode.mli
index d3c01b76b4d..f2a556790b4 100644
--- a/typing/typemode.mli
+++ b/typing/typemode.mli
@@ -13,6 +13,8 @@ val transl_alloc_mode : Parsetree.modes -> Mode.Alloc.Const.t
*)
val transl_modalities :
maturity:Language_extension.maturity ->
+ ?for_mutable_variable:bool ->
+ (* CR jrayman: come up with a better parameter *)
Types.mutability ->
Parsetree.modalities ->
Mode.Modality.Value.Const.t
diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml
index 1c80bbae77e..414c0193487 100644
--- a/typing/uniqueness_analysis.ml
+++ b/typing/uniqueness_analysis.ml
@@ -2139,7 +2139,7 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t =
in
UF.seq uf_vbs uf_body
| Texp_letmutable (vb, body) ->
- (* jra: not immediately clear this is correct *)
+ (* CR jrayman: not immediately clear this is correct *)
let ext, uf_vbs = check_uniqueness_value_bindings ienv [vb] in
let uf_body =
check_uniqueness_exp ~overwrite:None (Ienv.extend ienv ext) body
From 9da324e9d0351b60d5e5eb626d5b1f8a88c328df Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Thu, 5 Jun 2025 13:38:08 -0400
Subject: [PATCH 10/32] WIP
---
typing/env.ml | 30 +++++++-----
typing/env.mli | 2 +
typing/typecore.ml | 112 ++++++++++++++++++++++----------------------
typing/typecore.mli | 6 +--
typing/types.ml | 8 +++-
typing/types.mli | 7 ++-
6 files changed, 93 insertions(+), 72 deletions(-)
diff --git a/typing/env.ml b/typing/env.ml
index d6790c1d521..92737566be7 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -830,6 +830,18 @@ let mode_default mode = {
context = None
}
+(* CR jrayman: maybe not the best place to put these *)
+let modalities_for_mutvar =
+ Typemode.transl_modalities ~maturity:Stable
+ ~for_mutable_variable:true (Mutable mutability_for_mutvar) []
+
+let m0_for_mutvar =
+ Mode.Alloc.Const.merge
+ {comonadic = mutability_for_mutvar;
+ monadic = Mode.Alloc.Monadic.Const.min}
+ |> Mode.Const.alloc_as_value |> Mode.Value.of_const
+ |> Mode.Modality.Value.Const.apply modalities_for_mutvar
+
let env_labels (type rep) (record_form : rep record_form) env
: rep gen_label_description TycompTbl.t =
match record_form with
@@ -3337,15 +3349,11 @@ let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks =
let lookup_ident_value ~errors ~use ~loc name env =
match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with
| Ok (path, locks, Val_bound vda) ->
- let vda =
- match vda with
- | {vda_description={val_kind=Val_mut (m0, sort); _}; _} ->
- let m0 = walk_locks_for_mutable_mode ~errors ~loc ~env m0 locks in
- let val_kind = Val_mut (m0, sort) in
- let vda_description = {vda.vda_description with val_kind} in
- {vda with vda_description}
- | _ -> vda
- in
+ begin match vda with
+ | {vda_description={val_kind=Val_mut _; _}; _} ->
+ walk_locks_for_mutable_mode ~errors ~loc ~env m0_for_mutvar locks
+ |> ignore
+ | _ -> () end;
use_value ~use ~loc path vda;
path, locks, vda
| Ok (_, _, Val_unbound reason) ->
@@ -4093,12 +4101,12 @@ 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(m0, sort), Pident id ->
+ | Val_mut sort, Pident id ->
let val_type = Subst.Lazy.force_type_expr desc.val_type in
let mode =
walk_locks_for_mutable_mode
~errors:true ~loc ~env
- m0 locks
+ m0_for_mutvar locks
in
use_value ~use ~loc path vda;
Mutable_variable (id, mode, val_type, sort)
diff --git a/typing/env.mli b/typing/env.mli
index 620d4c34fc2..0c4f89bb61d 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -280,6 +280,8 @@ type actual_mode = {
(** Explains why [mode] is high. *)
}
+val modalities_for_mutvar : Mode.Modality.Value.Const.t
+
(** Takes the [mode] and [ty] of a value at definition site, walks through the list of
locks and constrains [mode] and [ty]. Return the access mode of the value allowed by
the locks. [ty] is optional as the function works on modules and classes as well, for
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 6b77d788925..f3278f4f8ff 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1170,7 +1170,7 @@ type pattern_variable =
pv_id: Ident.t;
pv_uid: Uid.t;
pv_mode: Value.l;
- pv_mutable: mutability;
+ pv_mutable: mutable_flag;
pv_type: type_expr;
pv_loc: Location.t;
pv_as_var: bool;
@@ -1271,7 +1271,7 @@ 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
+ | Mutable -> f_mut pv_type) pvs
let add_pattern_variables ?check ?check_as env pv =
List.fold_right
@@ -1280,20 +1280,16 @@ let add_pattern_variables ?check ?check_as env pv =
let check = if pv_as_var then check_as else check in
let kind = match pv_mutable with
| Immutable -> Val_reg
- | Mutable mode ->
- let modalities =
- Typemode.transl_modalities ~maturity:Stable
- ~for_mutable_variable:true pv_mutable []
- in
- Val_mut (mutable_mode mode |> Modality.Value.Const.apply modalities,
- match
- (* CR-someday let_mutable: move the sort calculation elsewhere *)
- Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
- ~fixed:false env pv_type
- with
- | Ok sort -> sort
- | Error err -> raise(Error(pv_loc, env,
- Mutable_var_not_rep(pv_type, err))))
+ | Mutable ->
+ Val_mut
+ (* CR-someday let_mutable: move the sort calculation elsewhere *)
+ (match
+ Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
+ ~fixed:false env pv_type
+ with
+ | Ok sort -> sort
+ | Error err -> raise(Error(pv_loc, env,
+ Mutable_var_not_rep(pv_type, err))))
in
Env.add_value ?check ~mode:pv_mode pv_id
{val_type = pv_type; val_kind = kind; Types.val_loc = pv_loc;
@@ -1344,7 +1340,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
- mutability 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));
@@ -1378,7 +1374,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 = mutability;
+ pv_mutable = mutable_flag;
pv_type = ty;
pv_loc = loc;
pv_as_var = is_as_variable;
@@ -2676,25 +2672,25 @@ let components_have_label (labeled_components : (string option * 'a) list) =
let rec type_pat
: type k . type_pat_state -> k pattern_category ->
no_existentials: existential_restriction option ->
- alloc_mode:expected_pat_mode -> mutability:_ ->
+ 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 ~mutability ~penv sp
+ = 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 ~mutability ~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 -> mutability:_ -> penv:_ -> _ ->
+ alloc_mode:expected_pat_mode -> mutable_flag:_ -> penv:_ -> _ ->
_ -> k general_pattern
- = fun tps category ~no_existentials ~alloc_mode ~mutability ~penv sp
+ = 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 ~mutability ~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 =
@@ -2884,7 +2880,7 @@ and type_pat_aux
cross_left !!penv expected_ty alloc_mode.mode
in
let id, uid =
- enter_variable tps loc name alloc_mode mutability ty
+ enter_variable tps loc name alloc_mode mutable_flag ty
sp.ppat_attributes
in
rvp {
@@ -2911,7 +2907,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 mutability
+ 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);
@@ -2927,7 +2923,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 mutability
+ 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);
@@ -3213,15 +3209,15 @@ and type_pat_aux
| Ppat_extension ext ->
raise (Error_forward (Builtin_attributes.error_of_extension ext))
-let type_pat tps category ?no_existentials ~mutability penv =
- type_pat tps category ~no_existentials ~mutability ~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 ~mutability:Immutable new_penv spat
+ type_pat tps category ~alloc_mode ~mutable_flag:Immutable new_penv spat
expected_ty
in
let { tps_pattern_variables = pvs;
@@ -3231,7 +3227,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 mutability 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
@@ -3242,7 +3238,7 @@ let type_pattern_list
(fun () ->
exp_mode,
type_pat tps category
- ~no_existentials ~alloc_mode:pat_mode ~mutability
+ ~no_existentials ~alloc_mode:pat_mode ~mutable_flag
new_penv pat ty
)
in
@@ -3264,7 +3260,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
- ~mutability:Immutable 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;
@@ -3327,7 +3323,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
- ~mutability:Immutable 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
@@ -5410,7 +5406,7 @@ let vb_pat_constraint
in
vb.pvb_attributes, spat
-let pat_modes ~force_toplevel rec_mode_var (attrs, spat) =
+let pat_modes ~force_toplevel ~mutable_flag rec_mode_var (attrs, spat) =
let pat_mode, exp_mode =
if force_toplevel
then simple_pat_mode Value.legacy, mode_legacy
@@ -5428,7 +5424,13 @@ let pat_modes ~force_toplevel rec_mode_var (attrs, spat) =
| Some mode ->
simple_pat_mode mode, mode_default mode
in
- attrs, pat_mode, exp_mode, spat
+ match (mutable_flag : mutable_flag) with
+ | Mutable
+ | Immutable -> attrs, pat_mode, exp_mode, spat
+ (* check_construct_mutability for exp_mode *)
+ (* [apply modalities] to [exp_mode] to get expected mode of content of cell *)
+ (* modalities to apply: Typemode.mutable_implied_modalities, only monadic *)
+ (* How do I get a ty here? *)
let add_zero_alloc_attribute expr attributes =
let open Builtin_attributes in
@@ -5778,7 +5780,12 @@ and type_expect_
| _ -> assert false)
| Val_mut _ -> begin
match path with
- | Path.Pident id -> Texp_mutvar {loc = lid.loc; txt = id}
+ | Path.Pident id ->
+ submode ~loc ~env
+ (Mode.Modality.Value.Const.apply
+ Env.modalities_for_mutvar actual_mode.mode)
+ expected_mode;
+ Texp_mutvar {loc = lid.loc; txt = id}
| _ ->
fatal_error "Typecore.type_expect_: \
bad mutable variable identifier"
@@ -5854,16 +5861,6 @@ and type_expect_
| Recursive -> Some In_rec
| Nonrecursive -> None
in
- (* CR-someday let_mutable: get mutability mode from parser. For now,
- * use the default mode [legacy \/ local] *)
- let mutability = match mutable_flag with
- | Immutable -> Immutable
- | Mutable ->
- Mutable
- { Mode.Alloc.Comonadic.Const.legacy with
- areality = Mode.Locality.Const.max;
- yielding = Mode.Yielding.Const.max }
- in
check_let_mutable mutable_flag env ?restriction spat_sexp_list;
let existential_context : existential_restriction =
if rec_flag = Recursive then In_rec
@@ -5888,7 +5885,7 @@ and type_expect_
else Modules_rejected
in
let (pat_exp_list, new_env) =
- type_let existential_context env mutability rec_flag
+ type_let existential_context env mutable_flag rec_flag
spat_sexp_list allow_modules
in
let body =
@@ -9221,7 +9218,7 @@ and type_function_cases_expect
(* Typing of let bindings *)
and type_let ?check ?check_strict ?(force_toplevel = false)
- existential_context env mutability rec_flag spat_sexp_list allow_modules =
+ existential_context env mutable_flag rec_flag spat_sexp_list allow_modules =
let rec sexp_is_fun sexp =
match sexp.pexp_desc with
| Pexp_function _ -> true
@@ -9247,7 +9244,10 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
| Nonrecursive -> None
in
let spatl = List.map vb_pat_constraint spat_sexp_list in
- let spatl = List.map (pat_modes ~force_toplevel rec_mode_var) spatl in
+ let spatl =
+ List.map
+ (pat_modes ~force_toplevel ~mutable_flag rec_mode_var) spatl
+ in
let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in
let is_recursive = (rec_flag = Recursive) in
@@ -9262,7 +9262,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 mutability existential_context env spatl
+ type_pattern_list Value mutable_flag existential_context env spatl
nvs allow_modules
) ~post:(fun (_, _, _, pvs, _) ->
iter_pattern_variables_type generalize pvs)
@@ -10076,7 +10076,7 @@ and type_comprehension_iterator
Value
~no_existentials:In_self_pattern
~alloc_mode:(simple_pat_mode Value.legacy)
- ~mutability:Immutable
+ ~mutable_flag:Immutable
penv
pattern
item_ty
@@ -10181,21 +10181,21 @@ let maybe_check_uniqueness_value_bindings vbl =
(* Typing of toplevel bindings *)
-let type_binding env mutability 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 mutability 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 mutability 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 mutability rec_flag spat_sexp_list
+ type_let existential_ctx env mutable_flag rec_flag spat_sexp_list
Modules_rejected
in
maybe_check_uniqueness_value_bindings pat_exp_list;
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 64f25943dd0..90d137c9e40 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -65,7 +65,7 @@ type pattern_variable =
pv_id: Ident.t;
pv_uid: Uid.t;
pv_mode: Mode.Value.l;
- pv_mutable: mutability;
+ pv_mutable: mutable_flag;
pv_type: type_expr;
pv_loc: Location.t;
pv_as_var: bool;
@@ -123,12 +123,12 @@ type module_patterns_restriction =
| Modules_ignored
val type_binding:
- Env.t -> mutability -> 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 -> mutability -> rec_flag ->
+ existential_restriction -> Env.t -> mutable_flag -> rec_flag ->
Parsetree.value_binding list ->
Typedtree.value_binding list * Env.t
val type_expression:
diff --git a/typing/types.ml b/typing/types.ml
index 32962ed2528..25271d8388e 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -22,6 +22,11 @@ type mutability =
| Immutable
| Mutable of Mode.Alloc.Comonadic.Const.t
+let mutability_for_mutvar =
+ { Mode.Alloc.Comonadic.Const.legacy with
+ areality = Mode.Locality.Const.max;
+ yielding = Mode.Yielding.Const.max }
+
let is_mutable = function
| Immutable -> false
| Mutable _ -> true
@@ -474,7 +479,8 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Mode.Value.r * Jkind_types.Sort.t
+ | Val_mut of Jkind_types.Sort.t
+ (* Mutable value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of
diff --git a/typing/types.mli b/typing/types.mli
index 7f0b57afa07..ff0e9cd9504 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -32,6 +32,9 @@ type mutability =
| Mutable of Mode.Alloc.Comonadic.Const.t
(** The upper bound of the new field value upon mutation. *)
+(** [mutability] for mutable variables ... CR jrayman *)
+val mutability_for_mutvar : Mode.Alloc.Comonadic.Const.t
+
(** Returns [true] is the [mutable_flag] is mutable. Should be called if not
interested in the payload of [Mutable]. *)
val is_mutable : mutability -> bool
@@ -649,7 +652,7 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Mode.Value.r * Jkind_types.Sort.t
+ | Val_mut of Jkind_types.Sort.t
(** Mutable value, declared as [let mutable(m0) x = ..]. The mode returned
here is [m0] adjusted for regions, suitable to be used as the expected
mode of the new content.
@@ -657,6 +660,8 @@ type value_kind =
Currently, the syntax is not supported and [m0] is fixed to be [local,
legacy]. After adjusting for regions, the mode here could be [global,
legacy].
+
+ CR jrayman: update comment
*)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
From c1a3656e9849a282771e714f682cef13dc7e7496 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 10 Jun 2025 12:25:03 -0400
Subject: [PATCH 11/32] WIP
---
.../tests/parsetree/source_jane_street.ml | 2 +-
testsuite/tests/typing-layouts/let_mutable.ml | 16 ++---
.../typing-layouts/let_mutable.reference | 1 -
testsuite/tests/typing-local/let_mutable.ml | 66 ++++++++++++++-----
typing/env.ml | 4 +-
typing/typecore.ml | 39 +++++++----
typing/types.ml | 2 +-
typing/types.mli | 2 +-
8 files changed, 88 insertions(+), 44 deletions(-)
diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml
index 646b6074bad..17aff0789dd 100644
--- a/testsuite/tests/parsetree/source_jane_street.ml
+++ b/testsuite/tests/parsetree/source_jane_street.ml
@@ -1489,7 +1489,7 @@ let triangle_10 = let mutable x = 0 in
for i = 1 to 10 do
x <- x + i
done;
- x
+ (x : int)
;;
[%%expect{|
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index 8429657de2b..c93171c0a1e 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -34,14 +34,14 @@ let triangle_f64 n =
let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float_u.to_float)
-let triangle_f32 n =
- let mutable sum = #0.0s in
- for i = 1 to n do
- sum <- Float32_u.add sum (Float32_u.of_int i)
- done;
- sum
-
-let () = Printf.printf "%.2f\n" (triangle_f32 10 |> Float32_u.to_float)
+(* let triangle_f32 n = *)
+(* let mutable sum = #0.0s in *)
+(* for i = 1 to n do *)
+(* sum <- Float32_u.add sum (Float32_u.of_int i) *)
+(* done; *)
+(* sum *)
+
+(* let () = Printf.printf "%.2f\n" (triangle_f32 10 |> Float32_u.to_float) *)
let triangle_i64 n =
diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference
index 017dceb4972..19ab4a5b430 100644
--- a/testsuite/tests/typing-layouts/let_mutable.reference
+++ b/testsuite/tests/typing-layouts/let_mutable.reference
@@ -1,5 +1,4 @@
55.00
-55.00
55
55
55 55 55.00
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 31c4e1d12e0..40fadd5f4c7 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -9,7 +9,7 @@ let foo1 y =
for i = 1 to 10 do
x <- x + i
done;
- x
+ (x : int)
let () = assert (Int.equal (foo1 0) 55)
let () = assert (Int.equal (foo1 42) 97)
@@ -18,15 +18,43 @@ let () = assert (Int.equal (foo1 42) 97)
val foo1 : int -> int = <fun>
|}]
-(* Test 1.2: basic usage with a nested record *)
+(* Test 1.2: basic usage with a nested record returning string *)
type t_1_2 = { str_1_2 : string ref }
let x_1_2 =
let mutable x = { str_1_2 = ref "Hi" } in
x <- { str_1_2 = ref "Bye" };
- x
+ (x.str_1_2.contents : string)
[%%expect{|
type t_1_2 = { str_1_2 : string ref; }
-val x_1_2 : t_1_2 = {str_1_2 = {contents = "Bye"}}
+val x_1_2 : string = "Bye"
+|}]
+
+(* Test 1.3: returning an immutable record *)
+type t_1_3 = { str_1_3 : string }
+let x_1_3 =
+ let mutable x = { str_1_3 = "Hi" } in
+ x <- { str_1_3 = "Bye" };
+ (x : t_1_3)
+[%%expect{|
+type t_1_3 = { str_1_3 : string; }
+Line 5, characters 3-4:
+5 | (x : t_1_3)
+ ^
+Error: This value escapes its region.
+|}]
+
+(* Test 1.4: returning a mutable nested record *)
+type t_1_4 = { str_1_4 : string ref }
+let x_1_4 =
+ let mutable x = { str_1_4 = ref "Hi" } in
+ x <- { str_1_4 = ref "Bye" };
+ (x : t_1_4)
+[%%expect{|
+type t_1_4 = { str_1_4 : string ref; }
+Line 5, characters 3-4:
+5 | (x : t_1_4)
+ ^
+Error: This value escapes its region.
|}]
@@ -202,10 +230,11 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
done; x
[%%expect{|
-val foo5_1 : 'a -> 'a = <fun>
-val foo5_2 : int -> int = <fun>
-val foo5_3 : int -> int = <fun>
-val foo5_4 : int -> int = <fun>
+Line 7, characters 17-18:
+7 | | (x :: xs) -> x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
|}]
(* Test 6: let mutable ... and ... is illegal *)
@@ -273,7 +302,7 @@ let f_11 () =
let mutable x = 10 in
let y = x in
x <- x + 10;
- (y,x)
+ ((y : int), (x : int))
let () = assert (f_11 () = (10,20))
[%%expect{|
@@ -304,10 +333,10 @@ let x_13_1 =
;;
[%%expect{|
val reset_ref : int ref @ unique -> unit = <fun>
-Line 5, characters 7-8:
-5 | x <- y;
- ^
-Error: This value is "aliased" but expected to be "unique".
+Line 6, characters 12-13:
+6 | reset_ref x;
+ ^
+Error: This value escapes its region.
|}]
(* Test 13.2: Unique mutable variable *)
@@ -317,7 +346,10 @@ let x_13_2 =
!x
;;
[%%expect{|
-val x_13_2 : int = 0
+Line 3, characters 12-13:
+3 | reset_ref x;
+ ^
+Error: This value escapes its region.
|}]
(* Test 13.3: Can't put a global in a local record *)
@@ -329,8 +361,10 @@ let y_13_3 =
!x
[%%expect{|
val x_13_3 : int ref = {contents = 0}
-
-Error: This value is "global" bet expected to be "local".
+Line 3, characters 14-37:
+3 | let mutable x @ local = ref (ref 0) in
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This value escapes its region.
|}]
(* Test 14: mutable functions *)
diff --git a/typing/env.ml b/typing/env.ml
index 92737566be7..01ec5afd7fe 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -833,11 +833,11 @@ let mode_default mode = {
(* CR jrayman: maybe not the best place to put these *)
let modalities_for_mutvar =
Typemode.transl_modalities ~maturity:Stable
- ~for_mutable_variable:true (Mutable mutability_for_mutvar) []
+ ~for_mutable_variable:true (Mutable mutable_mode_for_mutvar) []
let m0_for_mutvar =
Mode.Alloc.Const.merge
- {comonadic = mutability_for_mutvar;
+ {comonadic = mutable_mode_for_mutvar;
monadic = Mode.Alloc.Monadic.Const.min}
|> Mode.Const.alloc_as_value |> Mode.Value.of_const
|> Mode.Modality.Value.Const.apply modalities_for_mutvar
diff --git a/typing/typecore.ml b/typing/typecore.ml
index f3278f4f8ff..e653a381e5d 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1022,12 +1022,15 @@ let mutable_mode m0 =
(** Takes the mutability, the type and the modalities of a field, and expected
mode of the record (adjusted for allocation), check that the construction
would be allowed. This applies to mutable arrays similarly. *)
-let check_construct_mutability ~loc ~env mutability ty ?modalities block_mode =
+let check_construct_mutability ~loc ~env mutability ?ty ?modalities block_mode =
match mutability with
| Immutable -> ()
| Mutable m0 ->
let m0 = mutable_mode m0 in
- let m0 = cross_left env ty ?modalities m0 in
+ let m0 = match ty with
+ | Some ty -> cross_left env ty ?modalities m0
+ | None -> m0
+ in
submode ~loc ~env m0 block_mode
(** The [expected_mode] of the record when projecting a mutable field. *)
@@ -5406,7 +5409,7 @@ let vb_pat_constraint
in
vb.pvb_attributes, spat
-let pat_modes ~force_toplevel ~mutable_flag rec_mode_var (attrs, spat) =
+let pat_modes ~force_toplevel rec_mode_var (attrs, spat) =
let pat_mode, exp_mode =
if force_toplevel
then simple_pat_mode Value.legacy, mode_legacy
@@ -5424,13 +5427,7 @@ let pat_modes ~force_toplevel ~mutable_flag rec_mode_var (attrs, spat) =
| Some mode ->
simple_pat_mode mode, mode_default mode
in
- match (mutable_flag : mutable_flag) with
- | Mutable
- | Immutable -> attrs, pat_mode, exp_mode, spat
- (* check_construct_mutability for exp_mode *)
- (* [apply modalities] to [exp_mode] to get expected mode of content of cell *)
- (* modalities to apply: Typemode.mutable_implied_modalities, only monadic *)
- (* How do I get a ty here? *)
+ attrs, pat_mode, exp_mode, spat
let add_zero_alloc_attribute expr attributes =
let open Builtin_attributes in
@@ -5615,7 +5612,7 @@ and type_expect_
None, expected_mode
in
let type_label_exp overwrite ((_, label, _) as x) =
- check_construct_mutability ~loc ~env label.lbl_mut label.lbl_arg
+ check_construct_mutability ~loc ~env label.lbl_mut ~ty:label.lbl_arg
~modalities:label.lbl_modalities record_mode;
let argument_mode = mode_modality label.lbl_modalities record_mode in
type_label_exp ~overwrite true env argument_mode loc ty_record x record_form
@@ -5664,7 +5661,7 @@ and type_expect_
check_project_mutability ~loc:extended_expr_loc ~env lbl.lbl_mut mode;
let mode = Modality.Value.Const.apply lbl.lbl_modalities mode in
check_construct_mutability ~loc:record_loc ~env lbl.lbl_mut
- lbl.lbl_arg ~modalities:lbl.lbl_modalities record_mode;
+ ~ty:lbl.lbl_arg ~modalities:lbl.lbl_modalities record_mode;
let argument_mode =
mode_modality lbl.lbl_modalities record_mode
in
@@ -9246,7 +9243,21 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
let spatl = List.map vb_pat_constraint spat_sexp_list in
let spatl =
List.map
- (pat_modes ~force_toplevel ~mutable_flag rec_mode_var) spatl
+ (fun spat ->
+ let attrs, pat_mode, exp_mode, spat =
+ pat_modes ~force_toplevel rec_mode_var spat
+ in
+ match (mutable_flag : mutable_flag) with
+ | Mutable ->
+ let mutability = Mutable Types.mutable_mode_for_mutvar in
+ check_construct_mutability ~loc:spat.ppat_loc ~env
+ mutability exp_mode;
+ let modalities =
+ Typemode.transl_modalities ~maturity:Stable mutability [] in
+ let exp_mode = mode_modality modalities exp_mode in
+ attrs, pat_mode, exp_mode, spat
+ | Immutable -> attrs, pat_mode, exp_mode, spat
+ ) spatl
in
let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in
let is_recursive = (rec_flag = Recursive) in
@@ -9662,7 +9673,7 @@ and type_generic_array
let to_unify = type_ ty in
with_explanation explanation (fun () ->
unify_exp_types loc env to_unify (generic_instance ty_expected));
- check_construct_mutability ~loc ~env mutability ty array_mode;
+ check_construct_mutability ~loc ~env mutability ~ty array_mode;
let argument_mode = expect_mode_cross env ty argument_mode in
let argl =
List.map
diff --git a/typing/types.ml b/typing/types.ml
index 25271d8388e..db0d3e1010e 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -22,7 +22,7 @@ type mutability =
| Immutable
| Mutable of Mode.Alloc.Comonadic.Const.t
-let mutability_for_mutvar =
+let mutable_mode_for_mutvar =
{ Mode.Alloc.Comonadic.Const.legacy with
areality = Mode.Locality.Const.max;
yielding = Mode.Yielding.Const.max }
diff --git a/typing/types.mli b/typing/types.mli
index ff0e9cd9504..6fcf874fc45 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -33,7 +33,7 @@ type mutability =
(** The upper bound of the new field value upon mutation. *)
(** [mutability] for mutable variables ... CR jrayman *)
-val mutability_for_mutvar : Mode.Alloc.Comonadic.Const.t
+val mutable_mode_for_mutvar : Mode.Alloc.Comonadic.Const.t
(** Returns [true] is the [mutable_flag] is mutable. Should be called if not
interested in the payload of [Mutable]. *)
From e9907c7e0451810049769112f09ab0580d18531b Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 10 Jun 2025 13:20:39 -0400
Subject: [PATCH 12/32] WIP
---
parsing/parsetree.mli | 5 -----
testsuite/tests/typing-layouts/let_mutable.ml | 1 +
typing/typecore.ml | 20 +++++++++----------
typing/typemode.ml | 2 +-
typing/typemode.mli | 1 -
typing/types.ml | 3 +--
typing/types.mli | 15 +++-----------
7 files changed, 16 insertions(+), 31 deletions(-)
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d855e06b60d..fd41147ef93 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -377,11 +377,6 @@ and expression_desc =
when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}
and [mut] = {{!Asttypes.mutable_flag.Mutable}[Mutable]}.
Invariant: If [mut = Mutable] then [n = 1] and [rec = Nonrecursive] *)
-
- (* CR jrayman: The parser forbids the sugared function syntax with
- * [mut = Mutable] (e.g. [let mutable f x y = ..]) by checking if the RHS
- * of the binding is a ghost function expression. Does this method prevent
- * PPXs from generating mutable function bindings? *)
| Pexp_function of
function_param list * function_constraint * function_body
(** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index c93171c0a1e..c403c083d40 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -33,6 +33,7 @@ let triangle_f64 n =
let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float_u.to_float)
+(* CR jrayman: [Float32_u] is wrong. What is it supposed to be? *)
(* let triangle_f32 n = *)
(* let mutable sum = #0.0s in *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index e653a381e5d..455c4c1a49a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -9247,16 +9247,16 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
let attrs, pat_mode, exp_mode, spat =
pat_modes ~force_toplevel rec_mode_var spat
in
- match (mutable_flag : mutable_flag) with
- | Mutable ->
- let mutability = Mutable Types.mutable_mode_for_mutvar in
- check_construct_mutability ~loc:spat.ppat_loc ~env
- mutability exp_mode;
- let modalities =
- Typemode.transl_modalities ~maturity:Stable mutability [] in
- let exp_mode = mode_modality modalities exp_mode in
- attrs, pat_mode, exp_mode, spat
- | Immutable -> attrs, pat_mode, exp_mode, spat
+ match (mutable_flag : mutable_flag) with
+ | Mutable ->
+ let mutability = Mutable Types.mutable_mode_for_mutvar in
+ check_construct_mutability ~loc:spat.ppat_loc ~env
+ mutability exp_mode;
+ let modalities =
+ Typemode.transl_modalities ~maturity:Stable mutability [] in
+ let exp_mode = mode_modality modalities exp_mode in
+ attrs, pat_mode, exp_mode, spat
+ | Immutable -> attrs, pat_mode, exp_mode, spat
) spatl
in
let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in
diff --git a/typing/typemode.ml b/typing/typemode.ml
index d2a901aa361..5db8d017e3f 100644
--- a/typing/typemode.ml
+++ b/typing/typemode.ml
@@ -561,7 +561,7 @@ let sort_dedup_modalities ~warn l =
in
l |> List.stable_sort compare |> dedup ~on_dup |> List.map fst
-let transl_modalities ~maturity ?(for_mutable_variable=false) mut modalities =
+let transl_modalities ~maturity ?(for_mutable_variable = false) mut modalities =
let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable in
let modalities = List.map (transl_modality ~maturity) modalities in
(* axes listed in the order of implication. *)
diff --git a/typing/typemode.mli b/typing/typemode.mli
index f2a556790b4..0f419891592 100644
--- a/typing/typemode.mli
+++ b/typing/typemode.mli
@@ -14,7 +14,6 @@ val transl_alloc_mode : Parsetree.modes -> Mode.Alloc.Const.t
val transl_modalities :
maturity:Language_extension.maturity ->
?for_mutable_variable:bool ->
- (* CR jrayman: come up with a better parameter *)
Types.mutability ->
Parsetree.modalities ->
Mode.Modality.Value.Const.t
diff --git a/typing/types.ml b/typing/types.ml
index db0d3e1010e..9a9d407ea44 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -479,8 +479,7 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Jkind_types.Sort.t
- (* Mutable value *)
+ | Val_mut of Jkind_types.Sort.t (* Mutable value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of
diff --git a/typing/types.mli b/typing/types.mli
index 6fcf874fc45..fa80f9d1ed1 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -32,7 +32,8 @@ type mutability =
| Mutable of Mode.Alloc.Comonadic.Const.t
(** The upper bound of the new field value upon mutation. *)
-(** [mutability] for mutable variables ... CR jrayman *)
+(** [Mutable mutable_mode_for_mutvar] for mutable variables.
+ Currently [legacy, local]. *)
val mutable_mode_for_mutvar : Mode.Alloc.Comonadic.Const.t
(** Returns [true] is the [mutable_flag] is mutable. Should be called if not
@@ -652,17 +653,7 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Jkind_types.Sort.t
- (** Mutable value, declared as [let mutable(m0) x = ..]. The mode returned
- here is [m0] adjusted for regions, suitable to be used as the expected
- mode of the new content.
-
- Currently, the syntax is not supported and [m0] is fixed to be [local,
- legacy]. After adjusting for regions, the mode here could be [global,
- legacy].
-
- CR jrayman: update comment
- *)
+ | Val_mut of Jkind_types.Sort.t (* Mutable variable *)
| 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
From dce53e050d433b2107dd7d0a9aad39d26da5976f Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Wed, 11 Jun 2025 14:28:08 -0400
Subject: [PATCH 13/32] Test AST invariants
---
parsing/ast_invariants.ml | 13 +++-
testsuite/tests/ast-invariants/test.ml | 4 +-
testsuite/tests/ast-invariants/test.reference | 9 ---
.../tests/parse-errors/let_mutable_misc.ml | 63 +++++++++++++++++++
.../broken_invariants.compilers.reference | 16 +++++
testsuite/tests/parsing/broken_invariants.ml | 5 ++
testsuite/tests/parsing/illegal_ppx.ml | 29 +++++++++
testsuite/tests/typing-local/let_mutable.ml | 60 ------------------
8 files changed, 127 insertions(+), 72 deletions(-)
create mode 100644 testsuite/tests/parse-errors/let_mutable_misc.ml
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
index ccbfa4d4584..ba1dc9b1a38 100644
--- a/parsing/ast_invariants.ml
+++ b/parsing/ast_invariants.ml
@@ -29,6 +29,8 @@ let no_args loc = err loc "Function application with no argument."
let empty_let loc = err loc "Let with no bindings."
let mutable_rec_let loc = err loc "Mutable let binding cannot be recursive."
let multiple_mutable_let loc = err loc "Mutable let must have only one binding."
+let mutable_let_bad_pat loc =
+ err loc "Mutable let must have a variable on the left hand side."
let empty_type loc = err loc "Type declarations cannot be empty."
let complex_id loc = err loc "Functor application not allowed here."
let module_type_substitution_missing_rhs loc =
@@ -54,6 +56,12 @@ let check_empty_constraint ~loc ty mode =
| None, [] -> empty_constraint loc
| _ -> ()
+(* Is this pattern a single variable, possibly with a type annotation? *)
+let pat_is_var = function
+| Ppat_var _
+| Ppat_constraint ({ ppat_desc = Ppat_var _; _}, _, _) -> true
+| _ -> false
+
let iterator =
let super = Ast_iterator.default_iterator in
let type_declaration self td =
@@ -123,8 +131,9 @@ let iterator =
| Pexp_let (_, _, [], _) -> empty_let loc
| Pexp_let (Mutable, Recursive, _, _) -> mutable_rec_let loc
| Pexp_let (Mutable, _, l, _) when List.length l > 1 ->
- multiple_mutable_let loc
- (* CR jrayman: test previous two invariants *)
+ multiple_mutable_let loc
+ | Pexp_let (Mutable, _, [{ pvb_pat = {ppat_desc; _}; _}], _)
+ when not (pat_is_var ppat_desc) -> mutable_let_bad_pat loc
| Pexp_ident id
| Pexp_construct (id, _)
| Pexp_field (_, id)
diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml
index dfe1af49831..38d0dd6e2d6 100644
--- a/testsuite/tests/ast-invariants/test.ml
+++ b/testsuite/tests/ast-invariants/test.ml
@@ -63,7 +63,9 @@ let kind fn =
(* some test directories contain files that intentionally violate the
expectations of ast-invariants *)
let is_ok_dir dir =
- not (String.ends_with ~suffix:"tests/jane-modular-syntax" dir)
+ (* CR jrayman: this first directory doesn't seem to exist? *)
+ not (String.ends_with ~suffix:"tests/jane-modular-syntax" dir) &&
+ not (String.ends_with ~suffix:"tests/parse-errors" dir)
let rec walk dir =
if is_ok_dir dir then
diff --git a/testsuite/tests/ast-invariants/test.reference b/testsuite/tests/ast-invariants/test.reference
index 85aa6f6cd8f..e69de29bb2d 100644
--- a/testsuite/tests/ast-invariants/test.reference
+++ b/testsuite/tests/ast-invariants/test.reference
@@ -1,9 +0,0 @@
-File "/home/zqian/local/repos/let-mutable/_runtest/testsuite/tests/typing-local/let_mutable.ml", lines 200-206, characters 2-15:
-200 | ..let mutable x = []
-201 | and z = 3
-202 | in
-203 | x <- z :: x;
-204 | match x with
-205 | | [] -> 0
-206 | | z :: _ -> z
-Error: broken invariant in parsetree: Mutable let must have only one binding.
diff --git a/testsuite/tests/parse-errors/let_mutable_misc.ml b/testsuite/tests/parse-errors/let_mutable_misc.ml
new file mode 100644
index 00000000000..938869bea62
--- /dev/null
+++ b/testsuite/tests/parse-errors/let_mutable_misc.ml
@@ -0,0 +1,63 @@
+(* TEST
+ flags = "-extension let_mutable";
+ expect; *)
+
+(* Test 1: let mutable ... and ... is illegal *)
+let foo_1 () =
+ 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 2: mutable and rec don't mix *)
+let foo_2_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 3: only variable patterns may be mutable *)
+let foo_3_1 y =
+ let mutable (x1,x2) = (y,y+1) in
+ x1 <- x1 + 10;
+ x2 <- x2 + 20;
+ (x1,x2)
+
+[%%expect {|
+Line 2, characters 14-21:
+2 | let mutable (x1,x2) = (y,y+1) in
+ ^^^^^^^
+Error: Only variables are allowed as the left-hand side of "let mutable"
+|}]
+
+type t3_2 = {x_3_2 : int}
+let foo_3_2 y =
+ let mutable {x_3_2} = {x_3_2 = y + 1} in
+ x_3_2 <- x_3_2 + 10;
+ x_3_2
+
+
+[%%expect{|
+type t3_2 = { x_3_2 : int; }
+Line 3, characters 14-21:
+3 | let mutable {x_3_2} = {x_3_2 = y + 1} in
+ ^^^^^^^
+Error: Only variables are allowed as the left-hand side of "let mutable"
+|}]
diff --git a/testsuite/tests/parsing/broken_invariants.compilers.reference b/testsuite/tests/parsing/broken_invariants.compilers.reference
index d239e2f2709..c5f4cdf4edf 100644
--- a/testsuite/tests/parsing/broken_invariants.compilers.reference
+++ b/testsuite/tests/parsing/broken_invariants.compilers.reference
@@ -40,4 +40,20 @@ Line 2, characters 13-38:
2 | let f (_ : [%alias_with_too_many_nones]) = ();;
^^^^^^^^^^^^^^^^^^^^^^^^^
Error: broken invariant in parsetree: Alias types must have a name or a jkind.
+Line 2, characters 10-25:
+2 | let _ = [%mutable_let_rec];;
+ ^^^^^^^^^^^^^^^
+Error: broken invariant in parsetree: Mutable let binding cannot be recursive.
+Line 1, characters 10-30:
+1 | let _ = [%multiple_mutable_let];;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: broken invariant in parsetree: Mutable let must have only one binding.
+Line 1, characters 10-32:
+1 | let _ = [%mutable_let_ppat_tuple];;
+ ^^^^^^^^^^^^^^^^^^^^^^
+Error: broken invariant in parsetree: Mutable let must have a variable on the left hand side.
+Line 1, characters 10-30:
+1 | let _ = [%mutable_let_ppat_any];;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: broken invariant in parsetree: Mutable let must have a variable on the left hand side.
diff --git a/testsuite/tests/parsing/broken_invariants.ml b/testsuite/tests/parsing/broken_invariants.ml
index d1c269f7012..dab30f669b7 100644
--- a/testsuite/tests/parsing/broken_invariants.ml
+++ b/testsuite/tests/parsing/broken_invariants.ml
@@ -26,6 +26,11 @@ let f ([%nested_pat_constraint]) = ();;
let f (_ : [%alias_with_too_many_nones]) = ();;
+let _ = [%mutable_let_rec];;
+let _ = [%multiple_mutable_let];;
+let _ = [%mutable_let_ppat_tuple];;
+let _ = [%mutable_let_ppat_any];;
+
(* TEST
readonly_files = "illegal_ppx.ml";
setup-ocamlc.byte-build-env;
diff --git a/testsuite/tests/parsing/illegal_ppx.ml b/testsuite/tests/parsing/illegal_ppx.ml
index 877feb73215..e55d86d59f3 100644
--- a/testsuite/tests/parsing/illegal_ppx.ml
+++ b/testsuite/tests/parsing/illegal_ppx.ml
@@ -6,6 +6,29 @@ let empty_record loc = H.Exp.record ~loc [] None
let empty_apply loc f =
H.Exp.apply ~loc f []
+let foo_exp = H.Exp.constant (Pconst_char 'a') (* irrelevant what this
+ expression actually is *)
+let var ~loc name = H.Pat.var { txt = name; loc }
+
+let mutable_let_rec loc =
+ H.Exp.let_ ~loc Asttypes.Mutable Asttypes.Recursive
+ [H.Vb.mk (var ~loc "x") foo_exp] foo_exp
+
+let multiple_mutable_let loc =
+ H.Exp.let_ ~loc Asttypes.Mutable Asttypes.Nonrecursive
+ [H.Vb.mk (var ~loc "x") foo_exp; H.Vb.mk (var ~loc "y") foo_exp] foo_exp
+
+let mutable_let_ppat_tuple loc =
+ H.Exp.let_ ~loc Asttypes.Mutable Asttypes.Nonrecursive
+ [H.Vb.mk
+ (H.Pat.tuple [None, var ~loc "x"; None, var ~loc "y"] Closed) foo_exp]
+ foo_exp
+
+let mutable_let_ppat_any loc =
+ H.Exp.let_ ~loc Asttypes.Mutable Asttypes.Nonrecursive
+ [H.Vb.mk (H.Pat.any ()) foo_exp] foo_exp
+
+
let missing_rhs loc =
let name = Location.mkloc "T" loc in
let mtd = H.Mtd.mk ~loc name in
@@ -49,6 +72,12 @@ let expr mapper e =
| Pexp_extension({txt="record";loc},_) -> empty_record loc
| Pexp_extension({txt="no_args";loc},PStr[{pstr_desc= Pstr_eval (e,_);_}])
-> empty_apply loc e
+ | Pexp_extension ({txt="mutable_let_rec";loc},_) -> mutable_let_rec loc
+ | Pexp_extension ({txt="multiple_mutable_let";loc},_) -> multiple_mutable_let loc
+ | Pexp_extension ({txt="mutable_let_ppat_tuple";loc},_) ->
+ mutable_let_ppat_tuple loc
+ | Pexp_extension ({txt="mutable_let_ppat_any";loc},_) ->
+ mutable_let_ppat_any loc
| _ -> super.M.expr mapper e
let typ mapper t =
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 40fadd5f4c7..c62a6a75cf3 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -237,66 +237,6 @@ Error: This value escapes its region.
Hint: Cannot return a local value without an "exclave_" annotation.
|}]
-(* Test 6: let mutable ... and ... is illegal *)
-let foo_6 () =
- let mutable x = []
- and z = 3
- in
- x <- z :: x;
- match x with
- | [] -> 0
- | z :: _ -> z
-
-[%%expect{|
-Line 2, characters 14-15:
-2 | let mutable x = []
- ^
-Error: Mutable let bindings are not allowed as part of a `let .. and ..' group
-|}]
-
-(* Test 7: mutable and rec don't mix *)
-let foo_7_1 () =
- let mutable rec x = 1 :: x in
- match x with
- | [] -> 0
- | _ :: _ -> 1
-
-[%%expect{|
-Line 2, characters 18-19:
-2 | let mutable rec x = 1 :: x in
- ^
-Error: Mutable let bindings are not allowed to be recursive
-|}]
-
-(* Test 8: only variable patterns may be mutable *)
-let foo_8_1 y =
- let mutable (x1,x2) = (y,y+1) in
- x1 <- x1 + 10;
- x2 <- x2 + 20;
- (x1,x2)
-
-[%%expect {|
-Line 2, characters 14-21:
-2 | let mutable (x1,x2) = (y,y+1) in
- ^^^^^^^
-Error: Only variables are allowed as the left-hand side of "let mutable"
-|}]
-
-type t8_2 = {x_8_2 : int}
-let foo_8_2 y =
- let mutable {x_8_2} = {x_8_2 = y + 1} in
- x_8_2 <- x_8_2 + 10;
- x_8_2
-
-
-[%%expect{|
-type t8_2 = { x_8_2 : int; }
-Line 3, characters 14-21:
-3 | let mutable {x_8_2} = {x_8_2 = y + 1} in
- ^^^^^^^
-Error: Only variables are allowed as the left-hand side of "let mutable"
-|}]
-
(* Test 11: binding a mutable variable shouldn't be simplified away *)
let f_11 () =
let mutable x = 10 in
From f850fd0717b19dfe9dfcbb832e3cd5dbd69a9f6e Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Wed, 11 Jun 2025 14:40:58 -0400
Subject: [PATCH 14/32] Wrap lines
---
typing/env.ml | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/typing/env.ml b/typing/env.ml
index 01ec5afd7fe..7111ceab774 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -3336,13 +3336,16 @@ let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks =
be [local]. *)
mode
| Escape_lock (Letop | Probe | Class | Module as ctx) ->
- may_lookup_error errors loc env (Mutable_value_used_in_closure (`Escape ctx))
+ may_lookup_error errors loc env
+ (Mutable_value_used_in_closure (`Escape ctx))
| Share_lock (Letop | Probe | Class | Module as ctx) ->
- may_lookup_error errors loc env (Mutable_value_used_in_closure (`Shared ctx))
+ may_lookup_error errors loc env
+ (Mutable_value_used_in_closure (`Shared ctx))
| Share_lock (For_loop | While_loop | Comprehension) ->
mode
| Closure_lock _ ->
- may_lookup_error errors loc env (Mutable_value_used_in_closure `Closure)
+ may_lookup_error errors loc env
+ (Mutable_value_used_in_closure `Closure)
| Unboxed_lock -> mode
) mode locks
From ade25e2b4dedb9bb797e0ff7bb59e8f11bad8daa Mon Sep 17 00:00:00 2001
From: Zesen Qian <github@riaqn.org>
Date: Thu, 12 Jun 2025 11:11:26 +0100
Subject: [PATCH 15/32] mutable mode is inferred
---
testsuite/tests/typing-local/let_mutable.ml | 38 +++++++++-------
typing/env.ml | 48 ++++++++-------------
typing/env.mli | 2 -
typing/includecore.ml | 8 ++--
typing/printtyp.ml | 9 ++--
typing/printtyped.ml | 2 +-
typing/typecore.ml | 32 ++++++--------
typing/typedecl.ml | 2 +-
typing/typemode.ml | 7 ++-
typing/typemode.mli | 3 +-
typing/types.ml | 14 +++---
typing/types.mli | 13 +++---
typing/untypeast.ml | 8 ++--
13 files changed, 87 insertions(+), 99 deletions(-)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index c62a6a75cf3..26871b96137 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -37,10 +37,7 @@ let x_1_3 =
(x : t_1_3)
[%%expect{|
type t_1_3 = { str_1_3 : string; }
-Line 5, characters 3-4:
-5 | (x : t_1_3)
- ^
-Error: This value escapes its region.
+val x_1_3 : t_1_3 = {str_1_3 = "Bye"}
|}]
(* Test 1.4: returning a mutable nested record *)
@@ -51,10 +48,7 @@ let x_1_4 =
(x : t_1_4)
[%%expect{|
type t_1_4 = { str_1_4 : string ref; }
-Line 5, characters 3-4:
-5 | (x : t_1_4)
- ^
-Error: This value escapes its region.
+val x_1_4 : t_1_4 = {str_1_4 = {contents = "Bye"}}
|}]
@@ -203,6 +197,9 @@ let foo5_1 y = (* Assignment of local allowed in same scope *)
| (x :: xs) -> x
let () = assert Int.(equal 42 (foo5_1 42))
+[%%expect{|
+val foo5_1 : 'a -> 'a = <fun>
+|}]
let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
let mutable x = [] in
@@ -214,6 +211,9 @@ let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
| (x :: xs) -> x
let () = assert Int.(equal 42 (foo5_2 42))
+[%%expect{|
+val foo5_2 : int -> int = <fun>
+|}]
let foo5_3 y = (* Assignment of local works in _local_ while body region *)
let mutable x = y in
@@ -222,6 +222,9 @@ let foo5_3 y = (* Assignment of local works in _local_ while body region *)
x <- (local_ (x + !i));
i := !i + 1;
done; x
+[%%expect{|
+val foo5_3 : int -> int = <fun>
+|}]
let foo5_4 y = (* Assign of local works in _local_ while cond region *)
let mutable x = y in
@@ -230,11 +233,7 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
done; x
[%%expect{|
-Line 7, characters 17-18:
-7 | | (x :: xs) -> x
- ^
-Error: This value escapes its region.
- Hint: Cannot return a local value without an "exclave_" annotation.
+val foo5_4 : int -> int = <fun>
|}]
(* Test 11: binding a mutable variable shouldn't be simplified away *)
@@ -276,7 +275,7 @@ val reset_ref : int ref @ unique -> unit = <fun>
Line 6, characters 12-13:
6 | reset_ref x;
^
-Error: This value escapes its region.
+Error: This value is "aliased" but expected to be "unique".
|}]
(* Test 13.2: Unique mutable variable *)
@@ -289,7 +288,7 @@ let x_13_2 =
Line 3, characters 12-13:
3 | reset_ref x;
^
-Error: This value escapes its region.
+Error: This value is "aliased" but expected to be "unique".
|}]
(* Test 13.3: Can't put a global in a local record *)
@@ -375,3 +374,12 @@ Error: This expression has type "int" but an expression was expected of type
"float"
Hint: Did you mean "3."?
|}]
+
+(* some mode crossing *)
+let f () =
+ let mutable x : int = 42 in
+ x <- (local_ 24);
+ x
+[%%expect{|
+val f : unit -> int = <fun>
+|}]
diff --git a/typing/env.ml b/typing/env.ml
index 7111ceab774..8ab3191bcdd 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -830,18 +830,6 @@ let mode_default mode = {
context = None
}
-(* CR jrayman: maybe not the best place to put these *)
-let modalities_for_mutvar =
- Typemode.transl_modalities ~maturity:Stable
- ~for_mutable_variable:true (Mutable mutable_mode_for_mutvar) []
-
-let m0_for_mutvar =
- Mode.Alloc.Const.merge
- {comonadic = mutable_mode_for_mutvar;
- monadic = Mode.Alloc.Monadic.Const.min}
- |> Mode.Const.alloc_as_value |> Mode.Value.of_const
- |> Mode.Modality.Value.Const.apply modalities_for_mutvar
-
let env_labels (type rep) (record_form : rep record_form) env
: rep gen_label_description TycompTbl.t =
match record_form with
@@ -3316,25 +3304,23 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks =
) vmode locks
(** Take the parameter of [mutable(m0)] at declaration site, *)
-let walk_locks_for_mutable_mode ~errors ~loc ~env mode locks =
+let walk_locks_for_mutable_mode ~errors ~loc ~env locks mode =
List.fold_left
(fun (mode : Mode.Value.r) lock ->
match lock with
| Region_lock ->
- (* If [m0] is [global], then inside the region we require new values
- to be [global]. If [m0] is [local], morally inside the region we can
- require new values to be [regional]. However, GC doesn't support
- backward pointers inside a single stack frame. So we just require
- new values to be [global].
- *)
+ (* CR zqian: once we have finer regionality, remove this branch *)
+ (* First map [regional] to [global], then cap [local] to [regional] *)
+ let mode = mode |> Mode.value_to_alloc_r2g |> Mode.alloc_as_value in
Mode.Value.meet
[mode;
- Mode.Value.max_with (Comonadic Areality) (Mode.Regionality.global)]
+ Mode.Value.max_with (Comonadic Areality) (Mode.Regionality.regional)]
| Exclave_lock ->
(* If [m0] is [global], then inside the exclave we require new values
- to be [global]. If [m0] is [local], then we require the new values to
- be [local]. *)
- mode
+ to be [global]. If [m0] is [regional], then we require the new values to
+ be [local]. If [m0] is [local], that would trigger type error
+ elsewhere, so what we return here doesn't matter. *)
+ mode |> Mode.value_to_alloc_r2l |> Mode.alloc_as_value
| Escape_lock (Letop | Probe | Class | Module as ctx) ->
may_lookup_error errors loc env
(Mutable_value_used_in_closure (`Escape ctx))
@@ -3353,8 +3339,10 @@ let lookup_ident_value ~errors ~use ~loc name env =
match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with
| Ok (path, locks, Val_bound vda) ->
begin match vda with
- | {vda_description={val_kind=Val_mut _; _}; _} ->
- walk_locks_for_mutable_mode ~errors ~loc ~env m0_for_mutvar locks
+ | {vda_description={val_kind=Val_mut (m0, _); _}; _} ->
+ m0
+ |> mutable_mode |> Mode.Value.disallow_left
+ |> walk_locks_for_mutable_mode ~errors ~loc ~env locks
|> ignore
| _ -> () end;
use_value ~use ~loc path vda;
@@ -4104,12 +4092,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 sort, Pident id ->
+ | Val_mut (m0, sort), Pident id ->
let val_type = Subst.Lazy.force_type_expr desc.val_type in
let mode =
- walk_locks_for_mutable_mode
- ~errors:true ~loc ~env
- m0_for_mutvar locks
+ m0
+ |> mutable_mode |> Mode.Value.disallow_left
+ |> walk_locks_for_mutable_mode ~errors:true ~loc ~env locks
+ |> Mode.Modality.Value.Const.apply
+ (Typemode.let_mutable_modalities m0)
in
use_value ~use ~loc path vda;
Mutable_variable (id, mode, val_type, sort)
diff --git a/typing/env.mli b/typing/env.mli
index 0c4f89bb61d..620d4c34fc2 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -280,8 +280,6 @@ type actual_mode = {
(** Explains why [mode] is high. *)
}
-val modalities_for_mutvar : Mode.Modality.Value.Const.t
-
(** Takes the [mode] and [ty] of a value at definition site, walks through the list of
locks and constrains [mode] and [ty]. Return the access mode of the value allowed by
the locks. [ty] is optional as the function works on modules and classes as well, for
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 3901a6123aa..e571aea54a9 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -691,11 +691,9 @@ module Record_diffing = struct
| Mutable _, Immutable -> Some First
| Immutable, Mutable _ -> Some Second
| Mutable m1, Mutable m2 ->
- let open Mode.Alloc.Comonadic.Const in
- (if not (Misc.Le_result.equal ~le m1 legacy) then
- Misc.fatal_errorf "Unexpected mutable(%a)" print m1);
- (if not (Misc.Le_result.equal ~le m2 legacy) then
- Misc.fatal_errorf "Unexpected mutable(%a)" print m2);
+ let open Mode.Value.Comonadic in
+ equate_exn m1 legacy;
+ equate_exn m2 legacy;
None
in
begin match mut with
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index c6de16109d1..395a670d811 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -1840,11 +1840,10 @@ let tree_of_label l =
match l.ld_mutable with
| Mutable m ->
let mut =
- let open Alloc.Comonadic.Const in
- if Misc.Le_result.equal ~le m legacy then
- Om_mutable None
- else
- Om_mutable (Some "<non-legacy>")
+ let open Value.Comonadic in
+ match equate m legacy with
+ | Ok () -> Om_mutable None
+ | Error _ -> Om_mutable (Some "<non-legacy>")
in
mut
| Immutable -> Om_immutable
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 0aa71214bec..203a7c1202a 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -92,7 +92,7 @@ let fmt_mutable_mode_flag f (x : Types.mutability) =
match x with
| Immutable -> fprintf f "Immutable"
| Mutable m ->
- fprintf f "Mutable(%a)" Mode.Alloc.Comonadic.Const.print m
+ fprintf f "Mutable(%a)" (Mode.Value.Comonadic.print ()) m
let fmt_virtual_flag f x =
match x with
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 455c4c1a49a..5f214c64af6 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1010,15 +1010,6 @@ let apply_mode_annots ~loc ~env (m : Alloc.Const.Option.t) mode =
| Ok () -> ()
| Error e -> error (Right_le_left, e))
-(** Given the parameter [m0] on mutable, return the mode of future writes. *)
-let mutable_mode m0 =
- let m0 =
- Alloc.Const.merge
- {comonadic = m0;
- monadic = Alloc.Monadic.Const.min}
- in
- m0 |> Const.alloc_as_value |> Value.of_const
-
(** Takes the mutability, the type and the modalities of a field, and expected
mode of the record (adjusted for allocation), check that the construction
would be allowed. This applies to mutable arrays similarly. *)
@@ -1026,7 +1017,7 @@ let check_construct_mutability ~loc ~env mutability ?ty ?modalities block_mode =
match mutability with
| Immutable -> ()
| Mutable m0 ->
- let m0 = mutable_mode m0 in
+ let m0 = m0 |> mutable_mode |> Value.disallow_right in
let m0 = match ty with
| Some ty -> cross_left env ty ?modalities m0
| None -> m0
@@ -1284,9 +1275,11 @@ let add_pattern_variables ?check ?check_as env pv =
let kind = match pv_mutable with
| Immutable -> Val_reg
| Mutable ->
+ let m0 = Value.Comonadic.newvar () in
Val_mut
(* CR-someday let_mutable: move the sort calculation elsewhere *)
- (match
+ (m0,
+ match
Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
~fixed:false env pv_type
with
@@ -3094,7 +3087,7 @@ and type_pat_aux
| Ppat_array (mut, spl) ->
let mut =
match mut with
- | Mutable -> Mutable Alloc.Comonadic.Const.legacy
+ | Mutable -> Mutable Value.Comonadic.legacy
| Immutable ->
Language_extension.assert_enabled ~loc Immutable_arrays ();
Immutable
@@ -5775,12 +5768,12 @@ and type_expect_
match lid.txt with
Longident.Lident txt -> { txt; loc = lid.loc }
| _ -> assert false)
- | Val_mut _ -> begin
+ | Val_mut (m0, _) -> begin
match path with
| Path.Pident id ->
+ let modalities = Typemode.let_mutable_modalities m0 in
submode ~loc ~env
- (Mode.Modality.Value.Const.apply
- Env.modalities_for_mutvar actual_mode.mode)
+ (Mode.Modality.Value.Const.apply modalities actual_mode.mode)
expected_mode;
Texp_mutvar {loc = lid.loc; txt = id}
| _ ->
@@ -6312,7 +6305,7 @@ and type_expect_
| Pexp_array(mut, sargl) ->
let mutability =
match mut with
- | Mutable -> Mutable Alloc.Comonadic.Const.legacy
+ | Mutable -> Mutable Value.Comonadic.legacy
| Immutable ->
Language_extension.assert_enabled ~loc Immutable_arrays ();
Immutable
@@ -9249,9 +9242,10 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
in
match (mutable_flag : mutable_flag) with
| Mutable ->
- let mutability = Mutable Types.mutable_mode_for_mutvar in
+ let m0 = Value.Comonadic.newvar () in
+ let mutability = Mutable m0 in
check_construct_mutability ~loc:spat.ppat_loc ~env
- mutability exp_mode;
+ mutability exp_mode;
let modalities =
Typemode.transl_modalities ~maturity:Stable mutability [] in
let exp_mode = mode_modality modalities exp_mode in
@@ -9924,7 +9918,7 @@ and type_comprehension_expr ~loc ~env ~ty_expected ~attributes cexpr =
Predef.list_argument_jkind
| Pcomp_array_comprehension (amut, comp) ->
let container_type, mut = match amut with
- | Mutable -> Predef.type_array, Mutable Alloc.Comonadic.Const.legacy
+ | Mutable -> Predef.type_array, Mutable Value.Comonadic.legacy
| Immutable ->
Language_extension.assert_enabled ~loc Immutable_arrays ();
Predef.type_iarray, Immutable
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 9cd062417d5..8fcd2d9c81d 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -486,7 +486,7 @@ let transl_labels (type rep) ~(record_form : rep record_form) ~new_var_jkind
| Immutable -> Immutable
| Mutable ->
match record_form with
- | Legacy -> Mutable Mode.Alloc.Comonadic.Const.legacy
+ | Legacy -> Mutable Mode.Value.Comonadic.legacy
| Unboxed_product -> raise(Error(loc, Unboxed_mutable_label))
in
let modalities =
diff --git a/typing/typemode.ml b/typing/typemode.ml
index 5db8d017e3f..904e0a9af6f 100644
--- a/typing/typemode.ml
+++ b/typing/typemode.ml
@@ -561,8 +561,8 @@ let sort_dedup_modalities ~warn l =
in
l |> List.stable_sort compare |> dedup ~on_dup |> List.map fst
-let transl_modalities ~maturity ?(for_mutable_variable = false) mut modalities =
- let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable in
+let transl_modalities ~maturity mut modalities =
+ let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable:false in
let modalities = List.map (transl_modality ~maturity) modalities in
(* axes listed in the order of implication. *)
let modalities = sort_dedup_modalities ~warn:true modalities in
@@ -578,6 +578,9 @@ let transl_modalities ~maturity ?(for_mutable_variable = false) mut modalities =
m (implied_modalities t))
mut_modalities modalities
+let let_mutable_modalities m0 =
+ mutable_implied_modalities (Mutable m0) ~for_mutable_variable:true
+
let untransl_modalities mut t =
t
|> least_modalities_implying mut
diff --git a/typing/typemode.mli b/typing/typemode.mli
index 0f419891592..5a2965fce8e 100644
--- a/typing/typemode.mli
+++ b/typing/typemode.mli
@@ -13,11 +13,12 @@ val transl_alloc_mode : Parsetree.modes -> Mode.Alloc.Const.t
*)
val transl_modalities :
maturity:Language_extension.maturity ->
- ?for_mutable_variable:bool ->
Types.mutability ->
Parsetree.modalities ->
Mode.Modality.Value.Const.t
+val let_mutable_modalities : Mode.Value.Comonadic.lr -> Mode.Modality.Value.Const.t
+
val untransl_modality : Mode.Modality.t -> Parsetree.modality Location.loc
(** Un-interpret modalities back to parsetree. Takes the mutability and
diff --git a/typing/types.ml b/typing/types.ml
index 9a9d407ea44..f7155b65992 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -20,17 +20,17 @@ open Asttypes
type mutability =
| Immutable
- | Mutable of Mode.Alloc.Comonadic.Const.t
-
-let mutable_mode_for_mutvar =
- { Mode.Alloc.Comonadic.Const.legacy with
- areality = Mode.Locality.Const.max;
- yielding = Mode.Yielding.Const.max }
+ | Mutable of Mode.Value.Comonadic.lr
let is_mutable = function
| Immutable -> false
| Mutable _ -> true
+let mutable_mode m0 : _ Mode.Value.t =
+ { comonadic = m0
+ ; monadic = Mode.Value.Monadic.(min |> allow_left |> allow_right)
+ }
+
(* Type expressions for the core language *)
module Jkind_mod_bounds = struct
@@ -479,7 +479,7 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Jkind_types.Sort.t (* Mutable value *)
+ | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t (* Mutable value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of
diff --git a/typing/types.mli b/typing/types.mli
index fa80f9d1ed1..504944f7f63 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -29,17 +29,16 @@ open Asttypes
(** Describes a mutable field/element. *)
type mutability =
| Immutable
- | Mutable of Mode.Alloc.Comonadic.Const.t
- (** The upper bound of the new field value upon mutation. *)
-
-(** [Mutable mutable_mode_for_mutvar] for mutable variables.
- Currently [legacy, local]. *)
-val mutable_mode_for_mutvar : Mode.Alloc.Comonadic.Const.t
+ | Mutable of Mode.Value.Comonadic.lr
+ (** Mode of new field value in mutation. *)
(** Returns [true] is the [mutable_flag] is mutable. Should be called if not
interested in the payload of [Mutable]. *)
val is_mutable : mutability -> bool
+(** Given the parameter [m0] on mutable, return the mode of future writes. *)
+val mutable_mode : ('l * 'r) Mode.Value.Comonadic.t -> ('l * 'r) Mode.Value.t
+
(** Type expressions for the core language.
The [type_desc] variant defines all the possible type expressions one can
@@ -653,7 +652,7 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Jkind_types.Sort.t (* Mutable variable *)
+ | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t (* Mutable variable *)
| 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/untypeast.ml b/typing/untypeast.ml
index 114062aeb62..aac0e1bf17d 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -274,11 +274,9 @@ let mutable_ (mut : Types.mutability) : mutable_flag =
match mut with
| Immutable -> Immutable
| Mutable m ->
- let open Mode.Alloc.Comonadic.Const in
- if Misc.Le_result.equal ~le m legacy then
- Mutable
- else
- Misc.fatal_errorf "unexpected mutable(%a)" print m
+ let open Mode.Value.Comonadic in
+ equate_exn m legacy;
+ Mutable
let label_declaration sub ld =
let loc = sub.location sub ld.ld_loc in
From d6fb1c197fe674c93994ef823c1159b693bd0a57 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Thu, 12 Jun 2025 17:00:08 -0400
Subject: [PATCH 16/32] Remove comment
---
typing/uniqueness_analysis.ml | 1 -
1 file changed, 1 deletion(-)
diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml
index 414c0193487..10f7e016285 100644
--- a/typing/uniqueness_analysis.ml
+++ b/typing/uniqueness_analysis.ml
@@ -2139,7 +2139,6 @@ let rec check_uniqueness_exp ~overwrite (ienv : Ienv.t) exp : UF.t =
in
UF.seq uf_vbs uf_body
| Texp_letmutable (vb, body) ->
- (* CR jrayman: not immediately clear this is correct *)
let ext, uf_vbs = check_uniqueness_value_bindings ienv [vb] in
let uf_body =
check_uniqueness_exp ~overwrite:None (Ienv.extend ienv ext) body
From 54307f86a41be1053b153c8a6eeff462fa18b46b Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Thu, 12 Jun 2025 17:06:03 -0400
Subject: [PATCH 17/32] make fmt
---
typing/typemode.ml | 4 +++-
typing/typemode.mli | 3 ++-
2 files changed, 5 insertions(+), 2 deletions(-)
diff --git a/typing/typemode.ml b/typing/typemode.ml
index 904e0a9af6f..1eebc6ce28f 100644
--- a/typing/typemode.ml
+++ b/typing/typemode.ml
@@ -562,7 +562,9 @@ let sort_dedup_modalities ~warn l =
l |> List.stable_sort compare |> dedup ~on_dup |> List.map fst
let transl_modalities ~maturity mut modalities =
- let mut_modalities = mutable_implied_modalities mut ~for_mutable_variable:false in
+ let mut_modalities =
+ mutable_implied_modalities mut ~for_mutable_variable:false
+ in
let modalities = List.map (transl_modality ~maturity) modalities in
(* axes listed in the order of implication. *)
let modalities = sort_dedup_modalities ~warn:true modalities in
diff --git a/typing/typemode.mli b/typing/typemode.mli
index 5a2965fce8e..2c488c2e796 100644
--- a/typing/typemode.mli
+++ b/typing/typemode.mli
@@ -17,7 +17,8 @@ val transl_modalities :
Parsetree.modalities ->
Mode.Modality.Value.Const.t
-val let_mutable_modalities : Mode.Value.Comonadic.lr -> Mode.Modality.Value.Const.t
+val let_mutable_modalities :
+ Mode.Value.Comonadic.lr -> Mode.Modality.Value.Const.t
val untransl_modality : Mode.Modality.t -> Parsetree.modality Location.loc
From 41f64b4113628cbacaec73f429c434c8875a210c Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Thu, 12 Jun 2025 17:14:44 -0400
Subject: [PATCH 18/32] rewrap
---
typing/env.ml | 7 ++++---
typing/types.ml | 3 ++-
typing/types.mli | 3 ++-
3 files changed, 8 insertions(+), 5 deletions(-)
diff --git a/typing/env.ml b/typing/env.ml
index 8ab3191bcdd..ee2e2cbb8b2 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -3314,11 +3314,12 @@ let walk_locks_for_mutable_mode ~errors ~loc ~env locks mode =
let mode = mode |> Mode.value_to_alloc_r2g |> Mode.alloc_as_value in
Mode.Value.meet
[mode;
- Mode.Value.max_with (Comonadic Areality) (Mode.Regionality.regional)]
+ Mode.Value.max_with (Comonadic Areality)
+ (Mode.Regionality.regional)]
| Exclave_lock ->
(* If [m0] is [global], then inside the exclave we require new values
- to be [global]. If [m0] is [regional], then we require the new values to
- be [local]. If [m0] is [local], that would trigger type error
+ to be [global]. If [m0] is [regional], then we require the new values
+ to be [local]. If [m0] is [local], that would trigger type error
elsewhere, so what we return here doesn't matter. *)
mode |> Mode.value_to_alloc_r2l |> Mode.alloc_as_value
| Escape_lock (Letop | Probe | Class | Module as ctx) ->
diff --git a/typing/types.ml b/typing/types.ml
index f7155b65992..2f8ad313297 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -479,7 +479,8 @@ module Vars = Misc.Stdlib.String.Map
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t (* Mutable value *)
+ | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t
+ (* Mutable value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of
diff --git a/typing/types.mli b/typing/types.mli
index 504944f7f63..821d39aa3d1 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -652,7 +652,8 @@ module Vars : Map.S with type key = string
type value_kind =
Val_reg (* Regular value *)
- | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t (* Mutable variable *)
+ | Val_mut of Mode.Value.Comonadic.lr * Jkind_types.Sort.t
+ (* Mutable variable *)
| 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
From fe3bfe19c727126428025349a4d13def98790670 Mon Sep 17 00:00:00 2001
From: Zesen Qian <github@riaqn.org>
Date: Fri, 13 Jun 2025 11:45:45 +0100
Subject: [PATCH 19/32] fix unsoundness
---
testsuite/tests/typing-local/let_mutable.ml | 41 ++++++-
typing/typecore.ml | 117 ++++++++++----------
typing/typecore.mli | 2 +-
3 files changed, 94 insertions(+), 66 deletions(-)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 26871b96137..49507e0876d 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -198,7 +198,11 @@ let foo5_1 y = (* Assignment of local allowed in same scope *)
let () = assert Int.(equal 42 (foo5_1 42))
[%%expect{|
-val foo5_1 : 'a -> 'a = <fun>
+Line 7, characters 17-18:
+7 | | (x :: xs) -> x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
|}]
let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
@@ -213,6 +217,12 @@ let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
let () = assert Int.(equal 42 (foo5_2 42))
[%%expect{|
val foo5_2 : int -> int = <fun>
+|}, Principal{|
+Line 8, characters 17-18:
+8 | | (x :: xs) -> x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
|}]
let foo5_3 y = (* Assignment of local works in _local_ while body region *)
@@ -224,6 +234,12 @@ let foo5_3 y = (* Assignment of local works in _local_ while body region *)
done; x
[%%expect{|
val foo5_3 : int -> int = <fun>
+|}, Principal{|
+Line 7, characters 8-9:
+7 | done; x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
|}]
let foo5_4 y = (* Assign of local works in _local_ while cond region *)
@@ -234,6 +250,12 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
[%%expect{|
val foo5_4 : int -> int = <fun>
+|}, Principal{|
+Line 5, characters 8-9:
+5 | done; x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
|}]
(* Test 11: binding a mutable variable shouldn't be simplified away *)
@@ -300,10 +322,7 @@ let y_13_3 =
!x
[%%expect{|
val x_13_3 : int ref = {contents = 0}
-Line 3, characters 14-37:
-3 | let mutable x @ local = ref (ref 0) in
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This value escapes its region.
+val y_13_3 : int ref = {contents = 0}
|}]
(* Test 14: mutable functions *)
@@ -383,3 +402,15 @@ let f () =
[%%expect{|
val f : unit -> int = <fun>
|}]
+
+let foo1 y =
+ let mutable x = y in
+ (x <- stack_ (10 :: x));
+ x
+[%%expect{|
+Line 4, characters 2-3:
+4 | x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
+|}]
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 5f214c64af6..7daaf2d304a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1024,6 +1024,17 @@ let check_construct_mutability ~loc ~env mutability ?ty ?modalities block_mode =
in
submode ~loc ~env m0 block_mode
+(** Take [m0] which is the parameter to mutable, and the mode of the RHS (the
+ content expression), returns the strongest mode the mutable variable can be.
+*)
+let mutvar_mode ~loc ~env m0 exp_mode =
+ let m = Value.newvar () in
+ let mode = mode_default m in
+ let modalities = Typemode.let_mutable_modalities m0 in
+ submode ~loc ~env exp_mode (mode_modality modalities mode);
+ check_construct_mutability ~loc ~env (Mutable m0) ~modalities mode;
+ m |> Value.disallow_right
+
(** The [expected_mode] of the record when projecting a mutable field. *)
let mode_project_mutable =
let mode =
@@ -1164,7 +1175,7 @@ type pattern_variable =
pv_id: Ident.t;
pv_uid: Uid.t;
pv_mode: Value.l;
- pv_mutable: mutable_flag;
+ pv_kind : value_kind;
pv_type: type_expr;
pv_loc: Location.t;
pv_as_var: bool;
@@ -1262,33 +1273,18 @@ 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
+ List.iter (fun {pv_type; pv_kind; _ } ->
+ match pv_kind with
+ | Val_mut _ -> f_mut pv_type
+ | _ -> f_immut 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_mutable; pv_attributes; pv_uid} env ->
+ (fun {pv_id; pv_mode; pv_kind; pv_type; pv_loc; pv_as_var;
+ 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 ->
- let m0 = Value.Comonadic.newvar () in
- Val_mut
- (* CR-someday let_mutable: move the sort calculation elsewhere *)
- (m0,
- match
- Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
- ~fixed:false env pv_type
- with
- | Ok sort -> sort
- | Error err -> raise(Error(pv_loc, env,
- Mutable_var_not_rep(pv_type, err))))
- in
Env.add_value ?check ~mode:pv_mode pv_id
- {val_type = pv_type; val_kind = kind; Types.val_loc = pv_loc;
+ {val_type = pv_type; val_kind = pv_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
@@ -1336,7 +1332,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
- mutable_flag ty attrs =
+ ?(kind = Val_reg) 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));
@@ -1369,8 +1365,8 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name mode
let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
tps.tps_pattern_variables <-
{pv_id = id;
- pv_mode = Value.disallow_right mode;
- pv_mutable = mutable_flag;
+ pv_mode = mode;
+ pv_kind = kind;
pv_type = ty;
pv_loc = loc;
pv_as_var = is_as_variable;
@@ -1964,7 +1960,7 @@ let type_for_loop_like_index ~error ~loc ~env ~param ~any ~var =
any (Ident.create_local "_for", Uid.mk ~current_unit:(Env.get_unit_name ()))
| Ppat_var name ->
var ~name
- ~pv_mode:Value.min
+ ~pv_mode:Value.(min |> disallow_right)
~pv_type:(instance Predef.type_int)
~pv_loc:loc
~pv_as_var:false
@@ -1992,8 +1988,8 @@ 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_mutable=Immutable; pv_type; pv_loc; pv_as_var;
+ { pv_id; pv_uid; pv_mode;
+ pv_kind=Val_reg; pv_type; pv_loc; pv_as_var;
pv_attributes }
in
(pv_id, pv_uid), add_pattern_variables ~check ~check_as:check env [pv])
@@ -2015,7 +2011,6 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps =
pv_loc
name
pv_mode
- Immutable
pv_type
pv_attributes)
@@ -2681,7 +2676,7 @@ let rec type_pat
and type_pat_aux
: type k . type_pat_state -> k pattern_category -> no_existentials:_ ->
- alloc_mode:expected_pat_mode -> mutable_flag:_ -> penv:_ -> _ ->
+ alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> penv:_ -> _ ->
_ -> k general_pattern
= fun tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv sp
expected_ty ->
@@ -2875,9 +2870,28 @@ and type_pat_aux
let alloc_mode =
cross_left !!penv expected_ty alloc_mode.mode
in
+ let mode, kind =
+ match mutable_flag with
+ | Immutable -> alloc_mode, Val_reg
+ | Mutable ->
+ let m0 = Value.Comonadic.newvar () in
+ let mode = mutvar_mode ~loc ~env:!!penv m0 alloc_mode in
+ let kind =
+ Val_mut
+ (* CR-someday let_mutable: move the sort calculation elsewhere *)
+ (m0,
+ match
+ Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
+ ~fixed:false !!penv ty
+ with
+ | Ok sort -> sort
+ | Error err -> raise(Error(loc, !!penv,
+ Mutable_var_not_rep(ty, err))))
+ in
+ mode, kind
+ in
let id, uid =
- enter_variable tps loc name alloc_mode mutable_flag ty
- sp.ppat_attributes
+ enter_variable tps loc name mode ~kind ty sp.ppat_attributes
in
rvp {
pat_desc = Tpat_var (id, name, uid, alloc_mode);
@@ -2903,7 +2917,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 mutable_flag
+ let id, uid = enter_variable tps loc v alloc_mode.mode
t ~is_module:true sp.ppat_attributes in
rvp {
pat_desc = Tpat_var (id, v, uid, alloc_mode.mode);
@@ -2919,8 +2933,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 ty_var
+ sp.ppat_attributes
in
rvp { pat_desc = Tpat_alias(q, id, name, uid, mode, ty_var);
pat_loc = loc; pat_extra=[];
@@ -3223,7 +3237,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 mutable_flag no_existentials env spatl expected_tys allow_modules
+ category no_existentials env mutable_flag spatl expected_tys allow_modules
=
let tps = create_type_pat_state allow_modules in
let equations_scope = get_current_level () in
@@ -5772,9 +5786,10 @@ and type_expect_
match path with
| Path.Pident id ->
let modalities = Typemode.let_mutable_modalities m0 in
- submode ~loc ~env
- (Mode.Modality.Value.Const.apply modalities actual_mode.mode)
- expected_mode;
+ let mode =
+ Modality.Value.Const.apply modalities actual_mode.mode
+ in
+ submode ~loc ~env mode expected_mode;
Texp_mutvar {loc = lid.loc; txt = id}
| _ ->
fatal_error "Typecore.type_expect_: \
@@ -9234,25 +9249,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false)
| Nonrecursive -> None
in
let spatl = List.map vb_pat_constraint spat_sexp_list in
- let spatl =
- List.map
- (fun spat ->
- let attrs, pat_mode, exp_mode, spat =
- pat_modes ~force_toplevel rec_mode_var spat
- in
- match (mutable_flag : mutable_flag) with
- | Mutable ->
- let m0 = Value.Comonadic.newvar () in
- let mutability = Mutable m0 in
- check_construct_mutability ~loc:spat.ppat_loc ~env
- mutability exp_mode;
- let modalities =
- Typemode.transl_modalities ~maturity:Stable mutability [] in
- let exp_mode = mode_modality modalities exp_mode in
- attrs, pat_mode, exp_mode, spat
- | Immutable -> attrs, pat_mode, exp_mode, spat
- ) spatl
- in
+ let spatl = List.map (pat_modes ~force_toplevel rec_mode_var) spatl in
let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in
let is_recursive = (rec_flag = Recursive) in
@@ -9267,7 +9264,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 mutable_flag existential_context env spatl
+ type_pattern_list Value existential_context env mutable_flag spatl
nvs allow_modules
) ~post:(fun (_, _, _, pvs, _) ->
iter_pattern_variables_type generalize pvs)
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 90d137c9e40..83ce1bf6a4b 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -65,7 +65,7 @@ type pattern_variable =
pv_id: Ident.t;
pv_uid: Uid.t;
pv_mode: Mode.Value.l;
- pv_mutable: mutable_flag;
+ pv_kind: value_kind;
pv_type: type_expr;
pv_loc: Location.t;
pv_as_var: bool;
From aa3101957a08f6b60f3c9635e05f2e81b0d8f547 Mon Sep 17 00:00:00 2001
From: Zesen Qian <github@riaqn.org>
Date: Fri, 13 Jun 2025 11:54:45 +0100
Subject: [PATCH 20/32] fix tests
---
testsuite/tests/typing-local/alloc.ml | 3 +-
testsuite/tests/typing-local/let_mutable.ml | 32 ++++-----------------
2 files changed, 7 insertions(+), 28 deletions(-)
diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml
index 18420c1cd76..85628397161 100644
--- a/testsuite/tests/typing-local/alloc.ml
+++ b/testsuite/tests/typing-local/alloc.ml
@@ -476,7 +476,8 @@ let let_mutable_loop () =
for i = 0 to 10 do exclave_
x <- stack_ (i :: x)
done;
- ignore_local x
+ let () = ignore_local x in
+ ()
let run name f x =
let prebefore = Gc.allocated_bytes () in
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 49507e0876d..fd7cccd152d 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -194,15 +194,11 @@ let foo5_1 y = (* Assignment of local allowed in same scope *)
x <- (local_ (y :: x));
match x with
| [] -> assert false
- | (x :: xs) -> x
+ | (x :: xs) -> 42
let () = assert Int.(equal 42 (foo5_1 42))
[%%expect{|
-Line 7, characters 17-18:
-7 | | (x :: xs) -> x
- ^
-Error: This value escapes its region.
- Hint: Cannot return a local value without an "exclave_" annotation.
+val foo5_1 : 'a -> int = <fun>
|}]
let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
@@ -212,17 +208,11 @@ let foo5_2 y = (* Assignment of local works in _local_ for loop body region *)
done;
match x with
| [] -> assert false
- | (x :: xs) -> x
+ | (x :: xs) -> 42
let () = assert Int.(equal 42 (foo5_2 42))
[%%expect{|
val foo5_2 : int -> int = <fun>
-|}, Principal{|
-Line 8, characters 17-18:
-8 | | (x :: xs) -> x
- ^
-Error: This value escapes its region.
- Hint: Cannot return a local value without an "exclave_" annotation.
|}]
let foo5_3 y = (* Assignment of local works in _local_ while body region *)
@@ -231,31 +221,19 @@ let foo5_3 y = (* Assignment of local works in _local_ while body region *)
while !i <= 10 do exclave_
x <- (local_ (x + !i));
i := !i + 1;
- done; x
+ done; (x : int)
[%%expect{|
val foo5_3 : int -> int = <fun>
-|}, Principal{|
-Line 7, characters 8-9:
-7 | done; x
- ^
-Error: This value escapes its region.
- Hint: Cannot return a local value without an "exclave_" annotation.
|}]
let foo5_4 y = (* Assign of local works in _local_ while cond region *)
let mutable x = y in
while exclave_ x <- (local_ (x + 1)); x <= 100 do
x <- x + x
- done; x
+ done; (x : int)
[%%expect{|
val foo5_4 : int -> int = <fun>
-|}, Principal{|
-Line 5, characters 8-9:
-5 | done; x
- ^
-Error: This value escapes its region.
- Hint: Cannot return a local value without an "exclave_" annotation.
|}]
(* Test 11: binding a mutable variable shouldn't be simplified away *)
From a223febc1efc213c760da02b52e22dd4882d52bb Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 16 Jun 2025 12:29:10 -0400
Subject: [PATCH 21/32] Update documentation
---
.../let-mutable.md | 36 +++++++++++++------
1 file changed, 25 insertions(+), 11 deletions(-)
diff --git a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
index 496f9541e74..1f187297676 100644
--- a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
+++ b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
@@ -1,7 +1,9 @@
# The `let mutable` extension
-The `let mutable` extension provides a new type of `let` statement which
-declares a stack-local variable. It can be thought of as an unboxed `ref`.
+The `let mutable` extension provides a mechanism for creating mutable variables.
+This codifies a pre-existing optimization, where the compiler attempts to
+eliminate allocating a box for a `ref` when it can see the `ref` is only used
+locally in a given scope, instead simply storing the value in a register.
```ocaml
let triangle n =
@@ -12,17 +14,18 @@ let triangle n =
total
```
-Mutable variables must not escape their scope. For example, you can't
-return a closure that closes over a mutable variable. At the moment, the mode
-checker is, sadly, not sophisticated enough to allow some constructions which
-are obviously safe. For example, the following code is safe, but rejected by the
-mode checker.
+Mutable variables must not escape their scope. For example, a closure can't
+capture a mutable variable.
+
+Local data can be stored in a mutable variable. For example:
```ocaml
-let sum xs =
- let mutable total = 0 in
- List.iter xs ~f:(fun x -> total <- total + x);
- total
+let triangle_list n =
+ let mutable to_sum = [] in
+ for i = 1 to n do exclave_
+ to_sum <- stack_ (i :: to_sum)
+ done;
+ List.sum (module Int) to_sum
```
@@ -33,3 +36,14 @@ structure level or in class definitions. The pattern of a mutable `let`
statement must be a single variable, possibly with a type annotation, e.g. `let
mutable x, y = ..` and `let mutable add x y = ..` are not allowed. Mutable `let`
statements must also not use `and`s.
+
+Because closures may not capture mutable variables, some uses that are
+apparently safe from a scope perspective are not possible. For example, the
+following program is rejected:
+
+```ocaml
+let sum xs =
+ let mutable total = 0 in
+ List.iter xs ~f:(fun x -> total <- total + x);
+ total
+```
From 555da3fae972fdc0993b0fd66ad6fd3a7dbac601 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 16 Jun 2025 15:06:24 -0400
Subject: [PATCH 22/32] WIP
---
testsuite/tests/typing-layouts/let_mutable.ml | 22 ++++-----
.../typing-layouts/let_mutable.reference | 1 +
.../typing-layouts/let_mutable_native.ml | 29 ++++++++++++
.../let_mutable_native.reference | 1 +
testsuite/tests/typing-local/let_mutable.ml | 45 ++++++++++++++++++-
typing/typecore.ml | 17 ++++---
6 files changed, 95 insertions(+), 20 deletions(-)
create mode 100644 testsuite/tests/typing-layouts/let_mutable_native.ml
create mode 100644 testsuite/tests/typing-layouts/let_mutable_native.reference
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index c403c083d40..e0134ac1f52 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -1,6 +1,7 @@
(* TEST
reference = "${test_source_directory}/let_mutable.reference";
include stdlib_upstream_compatible;
+ include stdlib_stable;
flambda2;
{
flags = "-extension let_mutable";
@@ -23,6 +24,7 @@
}*)
open Stdlib_upstream_compatible
+module Float32_u = Stdlib_stable.Float32_u
let triangle_f64 n =
let mutable sum = #0.0 in
@@ -33,16 +35,17 @@ let triangle_f64 n =
let () = Printf.printf "%.2f\n" (triangle_f64 10 |> Float_u.to_float)
-(* CR jrayman: [Float32_u] is wrong. What is it supposed to be? *)
-(* let triangle_f32 n = *)
-(* let mutable sum = #0.0s in *)
-(* for i = 1 to n do *)
-(* sum <- Float32_u.add sum (Float32_u.of_int i) *)
-(* done; *)
-(* sum *)
+let triangle_f32 n =
+ let mutable sum = #0.0s in
+ for i = 1 to n do
+ sum <- Float32_u.add sum (Float32_u.of_int i)
+ done;
+ sum
-(* let () = Printf.printf "%.2f\n" (triangle_f32 10 |> Float32_u.to_float) *)
+let () =
+ Printf.printf "%.2f\n"
+ (triangle_f32 10 |> Float32_u.to_float |> Float_u.to_float)
let triangle_i64 n =
@@ -64,9 +67,6 @@ let triangle_i32 n =
let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int)
-
-(* CR jrayman: how do you create a vec128? *)
-
let triangle_i64_i32_f64 n =
let mutable sum = #(#0L, #(#0l, #0.)) in
for i = 1 to n do
diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference
index 19ab4a5b430..017dceb4972 100644
--- a/testsuite/tests/typing-layouts/let_mutable.reference
+++ b/testsuite/tests/typing-layouts/let_mutable.reference
@@ -1,4 +1,5 @@
55.00
+55.00
55
55
55 55 55.00
diff --git a/testsuite/tests/typing-layouts/let_mutable_native.ml b/testsuite/tests/typing-layouts/let_mutable_native.ml
new file mode 100644
index 00000000000..89cfeab245a
--- /dev/null
+++ b/testsuite/tests/typing-layouts/let_mutable_native.ml
@@ -0,0 +1,29 @@
+(* TEST
+ reference = "${test_source_directory}/let_mutable_native.reference";
+ include stdlib_upstream_compatible;
+ flambda2;
+ {
+ flags = "-extension let_mutable";
+ native;
+ }{
+ flags = "-extension layouts_alpha -extension let_mutable";
+ native;
+ }{
+ flags = "-extension layouts_beta -extension let_mutable";
+ native;
+ }*)
+
+open Stdlib_upstream_compatible
+
+let triangle_i64x2 n =
+ let mutable sum = Int64x2.const 0L 0L in
+ for i = 1 to n do
+ let i_u = Int64.of_int i in
+ sum <- Int64x2.add sum (Int64x2.const i_u i_u)
+ done;
+ #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
+
+let () =
+ let #(a, b) = triangle_i64x2 10 in
+ Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
+
diff --git a/testsuite/tests/typing-layouts/let_mutable_native.reference b/testsuite/tests/typing-layouts/let_mutable_native.reference
new file mode 100644
index 00000000000..aa08bdaf1b6
--- /dev/null
+++ b/testsuite/tests/typing-layouts/let_mutable_native.reference
@@ -0,0 +1 @@
+55 55
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index fd7cccd152d..dfb760a2b05 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -161,7 +161,7 @@ let foo4_5 y =
x <- local_ ((i*j) :: x)
done
done;
- x
+ 10
;;
[%%expect{|
Line 5, characters 11-30:
@@ -177,7 +177,7 @@ let foo4_6 y =
x <- local_ ((i*j) :: x)
done
done;
- x
+ 10
;;
[%%expect{|
Line 5, characters 11-30:
@@ -186,6 +186,47 @@ Line 5, characters 11-30:
Error: This value escapes its region.
|}]
+(* This is valid since both regions are closed *)
+let foo4_7 y =
+ let mutable x = [] in
+ for i = 1 to y do exclave_
+ for j = 1 to y do exclave_
+ x <- local_ ((i*j) :: x)
+ done
+ done;
+ 10
+;;
+[%%expect{|
+val foo4_7 : int -> int = <fun>
+|}]
+
+(* Can't return [x] if it is local *)
+let foo4_8 () =
+ let mutable x = [] in
+ (x <- stack_ (1 :: []));
+ x
+;;
+[%%expect{|
+Line 4, characters 2-3:
+4 | x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
+|}]
+
+(* Can't return [x] if it is local in some cases *)
+let foo4_9 b =
+ let mutable x = [] in
+ (x <- if b then 2 :: [] else stack_ (1 :: []));
+ x
+;;
+[%%expect{|
+Line 4, characters 2-3:
+4 | x
+ ^
+Error: This value escapes its region.
+ Hint: Cannot return a local value without an "exclave_" annotation.
+|}]
(* Test 5: Allowed interactions with locals. *)
let foo5_1 y = (* Assignment of local allowed in same scope *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 7daaf2d304a..f5db734e70a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2676,8 +2676,8 @@ let rec type_pat
and type_pat_aux
: type k . type_pat_state -> k pattern_category -> no_existentials:_ ->
- alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> penv:_ -> _ ->
- _ -> k general_pattern
+ alloc_mode:expected_pat_mode -> mutable_flag: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) =
@@ -2876,17 +2876,20 @@ and type_pat_aux
| Mutable ->
let m0 = Value.Comonadic.newvar () in
let mode = mutvar_mode ~loc ~env:!!penv m0 alloc_mode in
- let kind =
- Val_mut
- (* CR-someday let_mutable: move the sort calculation elsewhere *)
- (m0,
+ (* Sort information is used when translating a [Texp_mutvar] into an
+ [Lassign]. We calculate [sort] here so we can store and reuse it.
+ However, since we already make sure pattern variables are
+ representable, we are already calculating [sort] elsewhere, but
+ that place is too far removed to easily pass it here. *)
+ let sort =
match
Ctype.type_sort ~why:Jkind.History.Mutable_var_assignment
~fixed:false !!penv ty
with
| Ok sort -> sort
| Error err -> raise(Error(loc, !!penv,
- Mutable_var_not_rep(ty, err))))
+ Mutable_var_not_rep(ty, err)))
+ let kind = Val_mut (m0, sort)
in
mode, kind
in
From 89afbbab3679ac8c9ae1062a7abbc43c82066bac Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 16 Jun 2025 15:55:14 -0400
Subject: [PATCH 23/32] WIP
---
testsuite/tests/typing-local/let_mutable.ml | 45 +++++++++++++++++++++
typing/typecore.ml | 11 ++---
2 files changed, 51 insertions(+), 5 deletions(-)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index dfb760a2b05..5a291e6ba07 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -277,6 +277,51 @@ let foo5_4 y = (* Assign of local works in _local_ while cond region *)
val foo5_4 : int -> int = <fun>
|}]
+(* Test 6: Regionality *)
+(* 6.1: regional <- regional assignment is allowed *)
+let u_6_1 =
+ let mutable x = [] in
+ let y = stack_ (1 :: []) in
+ for i = 0 to 1 do
+ x <- y
+ done
+[%%expect{|
+val u_6_1 : unit = ()
+|}]
+
+(* 6.2: local <- regional assignment is not allowed *)
+let u_6_2 =
+ let mutable x = [] in
+ for i = 0 to 1 do
+ let z = stack_ (2 :: []) in
+ for j = 0 to 1 do
+ x <- z
+ done
+ done
+[%%expect{|
+Line 6, characters 11-12:
+6 | x <- z
+ ^
+Error: This value escapes its region.
+|}]
+
+(* 6.3: The mode system doesn't distinguish higher levels of regionality from
+ global, so this is not allowed *)
+let u_6_3 =
+ let mutable x = [] in
+ let y = stack_ (1 :: []) in
+ for i = 0 to 1 do
+ for j = 0 to 1 do
+ x <- y
+ done
+ done
+[%%expect{|
+Line 6, characters 11-12:
+6 | x <- y
+ ^
+Error: This value escapes its region.
+|}]
+
(* Test 11: binding a mutable variable shouldn't be simplified away *)
let f_11 () =
let mutable x = 10 in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index f5db734e70a..e2e64d822ce 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1332,7 +1332,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
- ?(kind = Val_reg) ty attrs =
+ ~kind 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));
@@ -2007,6 +2007,7 @@ let type_comprehension_for_range_iterator_index ~loc ~env ~param tps =
~var:(fun ~name ~pv_mode ~pv_type ~pv_loc ~pv_as_var ~pv_attributes ->
enter_variable
~is_as_variable:pv_as_var
+ ~kind:Val_reg
tps
pv_loc
name
@@ -2889,8 +2890,8 @@ and type_pat_aux
| Ok sort -> sort
| Error err -> raise(Error(loc, !!penv,
Mutable_var_not_rep(ty, err)))
- let kind = Val_mut (m0, sort)
in
+ let kind = Val_mut (m0, sort) in
mode, kind
in
let id, uid =
@@ -2921,7 +2922,7 @@ and type_pat_aux
[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
- t ~is_module:true sp.ppat_attributes in
+ t ~is_module:true ~kind:Val_reg sp.ppat_attributes in
rvp {
pat_desc = Tpat_var (id, v, uid, alloc_mode.mode);
pat_loc = sp.ppat_loc;
@@ -2936,8 +2937,8 @@ and type_pat_aux
let ty_var, mode = solve_Ppat_alias ~mode:alloc_mode.mode !!penv q in
let mode = cross_left !!penv expected_ty mode in
let id, uid =
- enter_variable ~is_as_variable:true tps name.loc name mode ty_var
- sp.ppat_attributes
+ enter_variable ~is_as_variable:true ~kind:Val_reg tps name.loc name mode
+ ty_var sp.ppat_attributes
in
rvp { pat_desc = Tpat_alias(q, id, name, uid, mode, ty_var);
pat_loc = loc; pat_extra=[];
From 11aafb1d9a51c470d910195d8091c1320c01157e Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Mon, 16 Jun 2025 16:21:43 -0400
Subject: [PATCH 24/32] WIP
---
testsuite/tests/typing-local/let_mutable.ml | 59 +++++++++++++++++++--
1 file changed, 54 insertions(+), 5 deletions(-)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 5a291e6ba07..231f33fea41 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -279,18 +279,18 @@ val foo5_4 : int -> int = <fun>
(* Test 6: Regionality *)
(* 6.1: regional <- regional assignment is allowed *)
-let u_6_1 =
+let allowed_6_1 =
let mutable x = [] in
let y = stack_ (1 :: []) in
for i = 0 to 1 do
x <- y
done
[%%expect{|
-val u_6_1 : unit = ()
+val allowed_6_1 : unit = ()
|}]
(* 6.2: local <- regional assignment is not allowed *)
-let u_6_2 =
+let disallowed_6_2 =
let mutable x = [] in
for i = 0 to 1 do
let z = stack_ (2 :: []) in
@@ -307,7 +307,7 @@ Error: This value escapes its region.
(* 6.3: The mode system doesn't distinguish higher levels of regionality from
global, so this is not allowed *)
-let u_6_3 =
+let disallowed_6_3 =
let mutable x = [] in
let y = stack_ (1 :: []) in
for i = 0 to 1 do
@@ -377,7 +377,8 @@ Line 3, characters 12-13:
Error: This value is "aliased" but expected to be "unique".
|}]
-(* Test 13.3: Can't put a global in a local record *)
+(* Test 13.3: [let mutable x @ m] checks only that the initial value of x has
+ mode [m]. *)
let x_13_3 = ref 0
let y_13_3 =
let mutable x @ local = ref (ref 0) in
@@ -389,6 +390,54 @@ val x_13_3 : int ref = {contents = 0}
val y_13_3 : int ref = {contents = 0}
|}]
+let require_portable (f : (int -> unit) @ portable) = ()
+[%%expect{|
+val require_portable : (int -> unit) @ portable -> unit = <fun>
+|}]
+
+(* Tests 13.4 to 13.7: Notice the [@ portable] does not prevent future values
+ from being non-portable, but the portability of future values of [f] is still
+ tracked. *)
+let allowed_13_4 =
+ let mutable f @ portable = fun _ -> () in
+ (f <- fun z -> ());
+ require_portable f
+[%%expect{|
+val allowed_13_4 : unit = ()
+|}]
+
+let allowed_13_5 =
+ let mutable f @ portable = fun _ -> () in
+ (f <- fun z -> x_13_3 := z)
+[%%expect{|
+val allowed_13_5 : unit = ()
+|}]
+
+let disallowed_13_6 =
+ let mutable f @ portable = fun _ -> () in
+ (f <- fun z -> x_13_3 := z);
+ require_portable f
+[%%expect{|
+Line 4, characters 19-20:
+4 | require_portable f
+ ^
+Error: This value is "nonportable" but expected to be "portable".
+|}]
+
+(* [f] remains non-portable even if a portable function is reassigned *)
+let disallowed_13_7 =
+ let mutable f @ portable = fun _ -> () in
+ (f <- fun z -> x_13_3 := z);
+ (f <- fun z -> ());
+ require_portable f
+[%%expect{|
+Line 5, characters 19-20:
+5 | require_portable f
+ ^
+Error: This value is "nonportable" but expected to be "portable".
+|}]
+
+
(* Test 14: mutable functions *)
let x_14 =
let mutable f = fun x -> 2*x in
From 8774dbb6cd55cc0f51ce753b90f08e176be7dd39 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 10:49:10 -0400
Subject: [PATCH 25/32] Add tests
---
testsuite/tests/typing-local/let_mutable.ml | 58 +++++++++++++++++++++
1 file changed, 58 insertions(+)
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 231f33fea41..26b1ddd035a 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -87,6 +87,53 @@ Line 5, characters 11-12:
Error: Mutable variable cannot be used inside closure.
|}]
+(* Tests 3.1 and 3.2: Disallow closures created by [lazy] *)
+let disallowed_3_1 =
+ let mutable x = 42 in
+ lazy x
+[%%expect{|
+Line 3, characters 7-8:
+3 | lazy x
+ ^
+Error: Mutable variable cannot be used inside closure.
+|}]
+
+let disallowed_3_2 =
+ let mutable x = 42 in
+ lazy (x + 1)
+[%%expect{|
+Line 3, characters 8-9:
+3 | lazy (x + 1)
+ ^
+Error: Mutable variable cannot be used inside closure.
+|}]
+
+(* Test 3.3: Locally defined functors *)
+module type S_3_3 = sig module F () : sig val x : int end end
+
+let m_3_3 =
+ let mutable y = 42 in
+ (module (struct module F () = struct let x = y end end) : S_3_3)
+
+[%%expect{|
+module type S_3_3 = sig module F : functor () -> sig val x : int end end
+val m_3_3 : (module S_3_3) = <module>
+|}]
+
+(* Test 3.4: Disallow closures in monadic operators *)
+let disallowed_3_4 =
+ let (let*) x f = f x in
+ let mutable x = 42 in
+ let* y = 0 in
+ x + y
+[%%expect{|
+Line 5, characters 2-3:
+5 | x + y
+ ^
+Error: Mutable variable cannot be used inside a letop.
+|}]
+
+
(* Test 4: Disallowed interactions with locals *)
let foo4_1 y =
let mutable x = [] in
@@ -347,6 +394,17 @@ type t_12 = Foo_12 of int
val y_12 : t_12 = Foo_12 42
|}]
+(* Test 12.1: Eta-expansion of reordered arguments *)
+let x_12_1 =
+ let f ~y ~x = (x, y) in
+ let mutable x = 42 in
+ let g = f ~x in
+ x <- 10;
+ g ~y:0
+[%%expect{|
+val x_12_1 : int * int = (42, 0)
+|}]
+
(* Test 13.1: Can't put aliased in unique mutable variable *)
let reset_ref (x @ unique) = x := 0;;
let x_13_1 =
From 9c9e3dec53e3ce899f2b6bbfa0bc39cd893553bf Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 11:23:12 -0400
Subject: [PATCH 26/32] WIP
---
testsuite/tests/typing-layouts/let_mutable_native.reference | 1 -
1 file changed, 1 deletion(-)
delete mode 100644 testsuite/tests/typing-layouts/let_mutable_native.reference
diff --git a/testsuite/tests/typing-layouts/let_mutable_native.reference b/testsuite/tests/typing-layouts/let_mutable_native.reference
deleted file mode 100644
index aa08bdaf1b6..00000000000
--- a/testsuite/tests/typing-layouts/let_mutable_native.reference
+++ /dev/null
@@ -1 +0,0 @@
-55 55
From 56bbcf52d1d83449c94dd5268fe5e7d1f29fcf97 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 12:30:42 -0400
Subject: [PATCH 27/32] WIP
---
.../let-mutable.md | 2 +
lambda/translcore.ml | 8 +++
lambda/translcore.mli | 1 +
oxcaml/tests/simd/dune | 60 +++++++++++++++++++
oxcaml/tests/simd/let_mutable.ml | 20 +++++++
oxcaml/tests/simd/let_mutable_u.ml | 23 +++++++
testsuite/tests/ast-invariants/test.ml | 2 -
testsuite/tests/typing-layouts/let_mutable.ml | 16 -----
.../typing-layouts/let_mutable.reference | 1 -
.../typing-layouts/let_mutable_native.ml | 29 ---------
testsuite/tests/typing-local/let_mutable.ml | 20 +++++--
11 files changed, 130 insertions(+), 52 deletions(-)
create mode 100644 oxcaml/tests/simd/let_mutable.ml
create mode 100644 oxcaml/tests/simd/let_mutable_u.ml
delete mode 100644 testsuite/tests/typing-layouts/let_mutable_native.ml
diff --git a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
index 1f187297676..4cbf37b028f 100644
--- a/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
+++ b/jane/doc/extensions/_11-miscellaneous-extensions/let-mutable.md
@@ -47,3 +47,5 @@ let sum xs =
List.iter xs ~f:(fun x -> total <- total + x);
total
```
+
+Unboxed products are not yet supported.
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
index a4007283bd9..306f676d4a9 100644
--- a/lambda/translcore.ml
+++ b/lambda/translcore.ml
@@ -36,6 +36,7 @@ type error =
| Void_sort of type_expr
| Unboxed_vector_in_array_comprehension
| Unboxed_product_in_array_comprehension
+ | Unboxed_product_in_let_mutable
exception Error of Location.t * error
@@ -1913,6 +1914,10 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false)
and transl_letmutable ~scopes ~return_layout
{vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc; vb_sort} body =
let arg_sort = Jkind_types.Sort.default_to_value_and_get vb_sort in
+ (match arg_sort with
+ | Product _ ->
+ raise (Error(expr.exp_loc, Unboxed_product_in_let_mutable))
+ | _ -> ());
let lam =
transl_bound_exp ~scopes ~in_structure:false pat arg_sort expr vb_loc attr
in
@@ -2512,6 +2517,9 @@ let report_error ppf = function
fprintf ppf
"Array comprehensions are not yet supported for arrays of unboxed \
products."
+ | Unboxed_product_in_let_mutable ->
+ fprintf ppf
+ "Mutable lets are not yet supported with unboxed products."
let () =
Location.register_error_of_exn
diff --git a/lambda/translcore.mli b/lambda/translcore.mli
index 02fcc7d79fb..7ba0a8c8ba9 100644
--- a/lambda/translcore.mli
+++ b/lambda/translcore.mli
@@ -54,6 +54,7 @@ type error =
| Void_sort of Types.type_expr
| Unboxed_vector_in_array_comprehension
| Unboxed_product_in_array_comprehension
+ | Unboxed_product_in_let_mutable
exception Error of Location.t * error
diff --git a/oxcaml/tests/simd/dune b/oxcaml/tests/simd/dune
index 06346cc6439..06df668ae3c 100644
--- a/oxcaml/tests/simd/dune
+++ b/oxcaml/tests/simd/dune
@@ -31,6 +31,8 @@
basic_u
basic256
basic256_u
+ let_mutable
+ let_mutable_u
ops
ops_u
arrays
@@ -45,6 +47,8 @@
basic_u
basic256
basic256_u
+ let_mutable
+ let_mutable_u
ops
ops_u
arrays
@@ -67,6 +71,8 @@
basic_u.out
basic256.out
basic256_u.out
+ let_mutable.out
+ let_mutable_u.out
ops.out
ops_u.out
arrays.out
@@ -81,6 +87,8 @@
basic_u.exe
basic256.exe
basic256_u.exe
+ let_mutable.exe
+ let_mutable_u.exe
ops.exe
arrays.exe
arrays_u.exe
@@ -103,6 +111,12 @@
(with-outputs-to
basic256_u.out
(run ./basic256_u.exe))
+ (with-outputs-to
+ let_mutable.out
+ (run ./let_mutable.exe))
+ (with-outputs-to
+ let_mutable_u.out
+ (run ./let_mutable_u.exe))
(with-outputs-to
ops.out
(run ./ops.exe))
@@ -143,6 +157,8 @@
(diff empty.expected basic_u.out)
(diff empty.expected basic256.out)
(diff empty.expected basic256_u.out)
+ (diff empty.expected let_mutable.out)
+ (diff empty.expected let_mutable_out.out)
(diff empty.expected ops.out)
(diff empty.expected ops_u.out)
(diff empty.expected arrays.out)
@@ -161,6 +177,8 @@
basic_u_nodynlink.ml
basic256_nodynlink.ml
basic256_u_nodynlink.ml
+ let_mutable_nodynlink.ml
+ let_mutable_u_nodynlink.ml
ops_nodynlink.ml
ops_u_nodynlink.ml
consts_nodynlink.ml
@@ -175,6 +193,8 @@
basic_u.ml
basic256.ml
basic256_u.ml
+ let_mutable.ml
+ let_mutable_u.ml
ops.ml
ops_u.ml
consts.ml
@@ -190,6 +210,8 @@
(copy basic_u.ml basic_u_nodynlink.ml)
(copy basic256.ml basic256_nodynlink.ml)
(copy basic256_u.ml basic256_u_nodynlink.ml)
+ (copy let_mutable.ml let_mutable_nodynlink.ml)
+ (copy let_mutable_u.ml let_mutable_u_nodynlink.ml)
(copy ops.ml ops_nodynlink.ml)
(copy ops_u.ml ops_u_nodynlink.ml)
(copy consts.ml consts_nodynlink.ml)
@@ -206,6 +228,8 @@
basic_u_nodynlink
basic256_nodynlink
basic256_u_nodynlink
+ let_mutable_nodynlink
+ let_mutable_u_nodynlink
ops_nodynlink
ops_u_nodynlink
consts_nodynlink
@@ -220,6 +244,8 @@
basic_u_nodynlink
basic256_nodynlink
basic256_u_nodynlink
+ let_mutable_nodynlink
+ let_mutable_u_nodynlink
ops_nodynlink
ops_u_nodynlink
consts_nodynlink
@@ -242,6 +268,8 @@
basic_u_nodynlink.out
basic256_nodynlink.out
basic256_u_nodynlink.out
+ let_mutable_nodynlink.out
+ let_mutable_u_nodynlink.out
ops_nodynlink.out
ops_u_nodynlink.out
consts_nodynlink.out
@@ -256,6 +284,8 @@
basic_u_nodynlink.exe
basic256_nodynlink.exe
basic256_u_nodynlink.exe
+ let_mutable_nodynlink.exe
+ let_mutable_u_nodynlink.exe
ops_nodynlink.exe
ops_u_nodynlink.exe
consts_nodynlink.exe
@@ -279,6 +309,12 @@
(with-outputs-to
basic256_u_nodynlink.out
(run ./basic256_u_nodynlink.exe))
+ (with-outputs-to
+ let_mutable_nodynlink.out
+ (run ./let_mutable_nodynlink.exe))
+ (with-outputs-to
+ let_mutable_u_nodynlink.out
+ (run ./let_mutable_u_nodynlink.exe))
(with-outputs-to
ops_nodynlink.out
(run ./ops_nodynlink.exe))
@@ -319,6 +355,8 @@
(diff empty.expected basic_u_nodynlink.out)
(diff empty.expected basic256_nodynlink.out)
(diff empty.expected basic256_u_nodynlink.out)
+ (diff empty.expected let_mutable_nodynlink.out)
+ (diff empty.expected let_mutable_u_nodynlink.out)
(diff empty.expected ops_nodynlink.out)
(diff empty.expected ops_u_nodynlink.out)
(diff empty.expected arrays_nodynlink.out)
@@ -346,6 +384,8 @@
basic_u_internal.ml
basic256_internal.ml
basic256_u_internal.ml
+ let_mutable_internal.ml
+ let_mutable_u_internal.ml
ops_internal.ml
ops_u_internal.ml
consts_internal.ml
@@ -360,6 +400,8 @@
basic_u.ml
basic256.ml
basic256_u.ml
+ let_mutable.ml
+ let_mutable_u.ml
ops.ml
ops_u.ml
consts.ml
@@ -373,6 +415,8 @@
(copy basic_u.ml basic_u_internal.ml)
(copy basic256.ml basic256_internal.ml)
(copy basic256_u.ml basic256_u_internal.ml)
+ (copy let_mutable.ml let_mutable_internal.ml)
+ (copy let_mutable_u.ml let_mutable_u_internal.ml)
(copy ops.ml ops_internal.ml)
(copy ops_u.ml ops_u_internal.ml)
(copy consts.ml consts_internal.ml)
@@ -389,6 +433,8 @@
basic_u_internal
basic256_internal
basic256_u_internal
+ let_mutable_internal
+ let_mutable_u_internal
ops_internal
ops_u_internal
consts_internal
@@ -403,6 +449,8 @@
basic_u_internal
basic256_internal
basic256_u_internal
+ let_mutable_internal
+ let_mutable_u_internal
ops_internal
ops_u_internal
consts_internal
@@ -431,6 +479,8 @@
basic_u_internal.out
basic256_internal.out
basic256_u_internal.out
+ let_mutable_internal.out
+ let_mutable_u_internal.out
ops_internal.out
ops_u_internal.out
consts_internal.out
@@ -447,6 +497,8 @@
basic_u_internal.exe
basic256_internal.exe
basic256_u_internal.exe
+ let_mutable_internal.exe
+ let_mutable_u_internal.exe
ops_internal.exe
ops_u_internal.exe
consts_internal.exe
@@ -470,6 +522,12 @@
(with-outputs-to
basic256_u_internal.out
(run ./basic256_u_internal.exe))
+ (with-outputs-to
+ let_mutable_internal.out
+ (run ./let_mutable_internal.exe))
+ (with-outputs-to
+ let_mutable_u_internal.out
+ (run ./let_mutable_u_internal.exe))
(with-outputs-to
basic_internal.out
(run ./basic_internal.exe))
@@ -519,6 +577,8 @@
(diff empty.expected basic_u_internal.out)
(diff empty.expected basic256_internal.out)
(diff empty.expected basic256_u_internal.out)
+ (diff empty.expected let_mutable_internal.out)
+ (diff empty.expected let_mutable_u_internal.out)
(diff empty.expected ops_internal.out)
(diff empty.expected ops_u_internal.out)
(diff empty.expected arrays_internal.out)
diff --git a/oxcaml/tests/simd/let_mutable.ml b/oxcaml/tests/simd/let_mutable.ml
new file mode 100644
index 00000000000..4aaaccbc1d4
--- /dev/null
+++ b/oxcaml/tests/simd/let_mutable.ml
@@ -0,0 +1,20 @@
+open Stdlib
+
+external int64x2_of_int64s : int64 -> int64 -> int64x2 = "" "vec128_of_int64s"
+ [@@noalloc] [@@unboxed]
+external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64"
+ [@@noalloc] [@@unboxed]
+external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64"
+ [@@noalloc] [@@unboxed]
+
+let triangle_i64x2 n =
+ let mutable sum = int64x2_of_int64s 0L 0L in
+ for i = 1 to n do
+ let i_u = Int64.of_int i in
+ sum <- Int64x2.add sum (Int64x2.const i_u i_u)
+ done;
+ #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
+
+let () =
+ let #(a, b) = triangle_i64x2 10 in
+ Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
diff --git a/oxcaml/tests/simd/let_mutable_u.ml b/oxcaml/tests/simd/let_mutable_u.ml
new file mode 100644
index 00000000000..a5398fb72e6
--- /dev/null
+++ b/oxcaml/tests/simd/let_mutable_u.ml
@@ -0,0 +1,23 @@
+open Stdlib
+
+external box_int64x2 : int64x2# -> int64x2 = "%box_vec128"
+external unbox_int64x2 : int64x2 -> int64x2# = "%unbox_vec128"
+
+external int64x2_of_int64s : int64 -> int64 -> int64x2 = "" "vec128_of_int64s"
+ [@@noalloc] [@@unboxed]
+external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64"
+ [@@noalloc] [@@unboxed]
+external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64"
+ [@@noalloc] [@@unboxed]
+
+let triangle_i64x2 n =
+ let mutable sum = int64x2_of_int64s 0L 0L in
+ for i = 1 to n do
+ let i_u = Int64.of_int i in
+ sum <- Int64x2.add sum (Int64x2.const i_u i_u)
+ done;
+ #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
+
+let () =
+ let #(a, b) = triangle_i64x2 10 in
+ Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml
index 38d0dd6e2d6..877f3c1f038 100644
--- a/testsuite/tests/ast-invariants/test.ml
+++ b/testsuite/tests/ast-invariants/test.ml
@@ -63,8 +63,6 @@ let kind fn =
(* some test directories contain files that intentionally violate the
expectations of ast-invariants *)
let is_ok_dir dir =
- (* CR jrayman: this first directory doesn't seem to exist? *)
- not (String.ends_with ~suffix:"tests/jane-modular-syntax" dir) &&
not (String.ends_with ~suffix:"tests/parse-errors" dir)
let rec walk dir =
diff --git a/testsuite/tests/typing-layouts/let_mutable.ml b/testsuite/tests/typing-layouts/let_mutable.ml
index e0134ac1f52..510661f446f 100644
--- a/testsuite/tests/typing-layouts/let_mutable.ml
+++ b/testsuite/tests/typing-layouts/let_mutable.ml
@@ -66,19 +66,3 @@ let triangle_i32 n =
sum
let () = Printf.printf "%d\n" (triangle_i32 10 |> Int32_u.to_int)
-
-let triangle_i64_i32_f64 n =
- let mutable sum = #(#0L, #(#0l, #0.)) in
- for i = 1 to n do
- let #(a, #(b, c)) = sum in
- sum <- #(Int64_u.add a (Int64_u.of_int i),
- #(Int32_u.add b (Int32_u.of_int i),
- Float_u.add c (Float_u.of_int i)))
- done;
- sum
-
-let () =
- let #(a, #(b, c)) = triangle_i64_i32_f64 10 in
- Printf.printf "%d %d %.2f\n" (Int64_u.to_int a)
- (Int32_u.to_int b)
- (Float_u.to_float c)
diff --git a/testsuite/tests/typing-layouts/let_mutable.reference b/testsuite/tests/typing-layouts/let_mutable.reference
index 017dceb4972..ac9dad34ae8 100644
--- a/testsuite/tests/typing-layouts/let_mutable.reference
+++ b/testsuite/tests/typing-layouts/let_mutable.reference
@@ -2,4 +2,3 @@
55.00
55
55
-55 55 55.00
diff --git a/testsuite/tests/typing-layouts/let_mutable_native.ml b/testsuite/tests/typing-layouts/let_mutable_native.ml
deleted file mode 100644
index 89cfeab245a..00000000000
--- a/testsuite/tests/typing-layouts/let_mutable_native.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-(* TEST
- reference = "${test_source_directory}/let_mutable_native.reference";
- include stdlib_upstream_compatible;
- flambda2;
- {
- flags = "-extension let_mutable";
- native;
- }{
- flags = "-extension layouts_alpha -extension let_mutable";
- native;
- }{
- flags = "-extension layouts_beta -extension let_mutable";
- native;
- }*)
-
-open Stdlib_upstream_compatible
-
-let triangle_i64x2 n =
- let mutable sum = Int64x2.const 0L 0L in
- for i = 1 to n do
- let i_u = Int64.of_int i in
- sum <- Int64x2.add sum (Int64x2.const i_u i_u)
- done;
- #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
-
-let () =
- let #(a, b) = triangle_i64x2 10 in
- Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
-
diff --git a/testsuite/tests/typing-local/let_mutable.ml b/testsuite/tests/typing-local/let_mutable.ml
index 26b1ddd035a..08a60294222 100644
--- a/testsuite/tests/typing-local/let_mutable.ml
+++ b/testsuite/tests/typing-local/let_mutable.ml
@@ -565,16 +565,16 @@ Error: This expression has type "int" but an expression was expected of type
Hint: Did you mean "3."?
|}]
-(* some mode crossing *)
-let f () =
+(* Tests 19 and 20: some mode crossing *)
+let f_19 () =
let mutable x : int = 42 in
x <- (local_ 24);
x
[%%expect{|
-val f : unit -> int = <fun>
+val f_19 : unit -> int = <fun>
|}]
-let foo1 y =
+let foo_20 y =
let mutable x = y in
(x <- stack_ (10 :: x));
x
@@ -585,3 +585,15 @@ Line 4, characters 2-3:
Error: This value escapes its region.
Hint: Cannot return a local value without an "exclave_" annotation.
|}]
+
+(* Test 21: Unboxed products not supported yet *)
+let foo_21 =
+ let mutable bar = #(123, 456) in
+ bar <- #(789, 101);
+ 42
+[%%expect{|
+Line 2, characters 20-31:
+2 | let mutable bar = #(123, 456) in
+ ^^^^^^^^^^^
+Error: Mutable lets are not yet supported with unboxed products.
+|}]
From d1ecd65e10e4bce1bf11737121606eeb49471c6d Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 12:57:48 -0400
Subject: [PATCH 28/32] Fix SIMD test
---
oxcaml/tests/.ocamlformat-ignore | 1 +
oxcaml/tests/simd/dune | 2 +-
oxcaml/tests/simd/let_mutable.ml | 16 ++++++++++++----
oxcaml/tests/simd/let_mutable_u.ml | 29 ++++++++++++++++++++---------
4 files changed, 34 insertions(+), 14 deletions(-)
diff --git a/oxcaml/tests/.ocamlformat-ignore b/oxcaml/tests/.ocamlformat-ignore
index 7a04aec4dce..0f07d34afe1 100644
--- a/oxcaml/tests/.ocamlformat-ignore
+++ b/oxcaml/tests/.ocamlformat-ignore
@@ -4,6 +4,7 @@ backend/vectorizer/test_float_unboxed.ml
backend/vectorizer/test_int32_unboxed.ml
backend/vectorizer/test_float32_unboxed.ml
simd/*_u.ml
+simd/let_mutable.ml
simd/unbox_types.ml
simd/arrays.ml
small_numbers/float32_u_lib.ml
diff --git a/oxcaml/tests/simd/dune b/oxcaml/tests/simd/dune
index 06df668ae3c..439b620dc01 100644
--- a/oxcaml/tests/simd/dune
+++ b/oxcaml/tests/simd/dune
@@ -158,7 +158,7 @@
(diff empty.expected basic256.out)
(diff empty.expected basic256_u.out)
(diff empty.expected let_mutable.out)
- (diff empty.expected let_mutable_out.out)
+ (diff empty.expected let_mutable_u.out)
(diff empty.expected ops.out)
(diff empty.expected ops_u.out)
(diff empty.expected arrays.out)
diff --git a/oxcaml/tests/simd/let_mutable.ml b/oxcaml/tests/simd/let_mutable.ml
index 4aaaccbc1d4..51da714b26f 100644
--- a/oxcaml/tests/simd/let_mutable.ml
+++ b/oxcaml/tests/simd/let_mutable.ml
@@ -6,15 +6,23 @@ external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64"
[@@noalloc] [@@unboxed]
external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64"
[@@noalloc] [@@unboxed]
+external boxed_combine : int64x2 -> int64x2 -> int64x2 = "" "boxed_combine"
+ [@@noalloc]
+
+let eq l r = if l <> r then Printf.printf "%Ld <> %Ld\n" l r
+
+let[@inline never] check v l h =
+ let vl, vh = int64x2_low_int64 v, int64x2_high_int64 v in
+ eq vl l;
+ eq vh h
let triangle_i64x2 n =
let mutable sum = int64x2_of_int64s 0L 0L in
for i = 1 to n do
let i_u = Int64.of_int i in
- sum <- Int64x2.add sum (Int64x2.const i_u i_u)
+ sum <- boxed_combine sum (int64x2_of_int64s i_u i_u)
done;
- #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
+ sum
let () =
- let #(a, b) = triangle_i64x2 10 in
- Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
+ check (triangle_i64x2 10) 55L 55L
diff --git a/oxcaml/tests/simd/let_mutable_u.ml b/oxcaml/tests/simd/let_mutable_u.ml
index a5398fb72e6..4c590e174f9 100644
--- a/oxcaml/tests/simd/let_mutable_u.ml
+++ b/oxcaml/tests/simd/let_mutable_u.ml
@@ -1,23 +1,34 @@
open Stdlib
-external box_int64x2 : int64x2# -> int64x2 = "%box_vec128"
-external unbox_int64x2 : int64x2 -> int64x2# = "%unbox_vec128"
-
external int64x2_of_int64s : int64 -> int64 -> int64x2 = "" "vec128_of_int64s"
[@@noalloc] [@@unboxed]
external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64"
[@@noalloc] [@@unboxed]
external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64"
[@@noalloc] [@@unboxed]
+external boxed_combine : int64x2 -> int64x2 -> int64x2 = "" "boxed_combine"
+ [@@noalloc]
+external box : int64x2# -> int64x2 = "%box_vec128"
+external unbox : int64x2 -> int64x2# = "%unbox_vec128"
+
+
+let combine : int64x2# -> int64x2# -> int64x2# = fun x y ->
+ unbox (boxed_combine (box x) (box y))
+
+let eq l r = if l <> r then Printf.printf "%Ld <> %Ld\n" l r
+
+let[@inline never] check v l h =
+ let vl, vh = int64x2_low_int64 v, int64x2_high_int64 v in
+ eq vl l;
+ eq vh h
-let triangle_i64x2 n =
- let mutable sum = int64x2_of_int64s 0L 0L in
+let triangle_i64x2_u n =
+ let mutable sum = unbox (int64x2_of_int64s 0L 0L) in
for i = 1 to n do
let i_u = Int64.of_int i in
- sum <- Int64x2.add sum (Int64x2.const i_u i_u)
+ sum <- combine sum (unbox (int64x2_of_int64s i_u i_u))
done;
- #(Int64x2.extract ~ind:0 sum, Int64x2.extract ~ind:1 sum)
+ sum
let () =
- let #(a, b) = triangle_i64x2 10 in
- Printf.printf "%d %d\n" (Int64.to_int a) (Int64.to_int b)
+ check (box (triangle_i64x2_u 10)) 55L 55L
From 683f05b5b61b99c3e8171575d3240f929913e84b Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 14:01:34 -0400
Subject: [PATCH 29/32] Fix `make minimizer`
---
chamelon/compat.ox.ml | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/chamelon/compat.ox.ml b/chamelon/compat.ox.ml
index c5e6a3112c0..36e96143494 100644
--- a/chamelon/compat.ox.ml
+++ b/chamelon/compat.ox.ml
@@ -308,7 +308,7 @@ type tpat_array_identifier = mutability * Jkind.sort
let mkTpat_array
?id:(mut, arg_sort =
- (Mutable Alloc.Comonadic.Const.legacy, Jkind.Sort.value)) l =
+ (Mutable Value.Comonadic.legacy, Jkind.Sort.value)) l =
Tpat_array (mut, arg_sort, l)
type tpat_tuple_identifier = string option list
From b00505cfa44dd4b123c1f9a411490f637d3271f9 Mon Sep 17 00:00:00 2001
From: Zesen Qian <zqian@janestreet.com>
Date: Tue, 17 Jun 2025 19:03:33 +0100
Subject: [PATCH 30/32] improve comments
---
typing/env.ml | 16 ++++++++++++----
typing/types.ml | 1 +
2 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/typing/env.ml b/typing/env.ml
index ee2e2cbb8b2..8b7b11de2b5 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -3303,8 +3303,18 @@ let walk_locks ~errors ~loc ~env ~item ~lid mode ty locks =
vmode
) vmode locks
-(** Take the parameter of [mutable(m0)] at declaration site, *)
-let walk_locks_for_mutable_mode ~errors ~loc ~env locks mode =
+(** Takes [m0] which is the parameter of [let mutable x] at declaration site,
+ and [locks] which is the locks between the declaration and the usage (either
+ reading or writing) of [x], and:
+- Raises error if the usage is forbidden by the locks
+- Returns the expected mode of the new value at the usage site (if the usage is
+ a write).
+*)
+let walk_locks_for_mutable_mode ~errors ~loc ~env locks m0 =
+ let mode =
+ m0
+ |> mutable_mode |> Mode.Value.disallow_left
+ in
List.fold_left
(fun (mode : Mode.Value.r) lock ->
match lock with
@@ -3342,7 +3352,6 @@ let lookup_ident_value ~errors ~use ~loc name env =
begin match vda with
| {vda_description={val_kind=Val_mut (m0, _); _}; _} ->
m0
- |> mutable_mode |> Mode.Value.disallow_left
|> walk_locks_for_mutable_mode ~errors ~loc ~env locks
|> ignore
| _ -> () end;
@@ -4097,7 +4106,6 @@ let lookup_settable_variable ?(use=true) ~loc name env =
let val_type = Subst.Lazy.force_type_expr desc.val_type in
let mode =
m0
- |> mutable_mode |> Mode.Value.disallow_left
|> walk_locks_for_mutable_mode ~errors:true ~loc ~env locks
|> Mode.Modality.Value.Const.apply
(Typemode.let_mutable_modalities m0)
diff --git a/typing/types.ml b/typing/types.ml
index 2f8ad313297..2a18a9cea01 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -26,6 +26,7 @@ let is_mutable = function
| Immutable -> false
| Mutable _ -> true
+(** Takes [m0] which is the parameter of [let mutable], returns the mode of new values in future writes. *)
let mutable_mode m0 : _ Mode.Value.t =
{ comonadic = m0
; monadic = Mode.Value.Monadic.(min |> allow_left |> allow_right)
From 5067f05307375cbf0fadc0dc64173d1a9e242896 Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 14:05:00 -0400
Subject: [PATCH 31/32] make fmt
---
chamelon/compat.ox.ml | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/chamelon/compat.ox.ml b/chamelon/compat.ox.ml
index 36e96143494..7e9a362d4c2 100644
--- a/chamelon/compat.ox.ml
+++ b/chamelon/compat.ox.ml
@@ -307,8 +307,7 @@ let mkTpat_alias ~id:(mode, ty) (p, ident, name) =
type tpat_array_identifier = mutability * Jkind.sort
let mkTpat_array
- ?id:(mut, arg_sort =
- (Mutable Value.Comonadic.legacy, Jkind.Sort.value)) l =
+ ?id:(mut, arg_sort = (Mutable Value.Comonadic.legacy, Jkind.Sort.value)) l =
Tpat_array (mut, arg_sort, l)
type tpat_tuple_identifier = string option list
From fbc143bf1c39f0bef5fdf01ea1a3d9fc482b84cf Mon Sep 17 00:00:00 2001
From: James Rayman <james@jamesrayman.com>
Date: Tue, 17 Jun 2025 14:10:09 -0400
Subject: [PATCH 32/32] 80ch
---
typing/types.ml | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/typing/types.ml b/typing/types.ml
index 2a18a9cea01..ad53e0cdd78 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -26,7 +26,8 @@ let is_mutable = function
| Immutable -> false
| Mutable _ -> true
-(** Takes [m0] which is the parameter of [let mutable], returns the mode of new values in future writes. *)
+(** Takes [m0] which is the parameter of [let mutable], returns the
+ mode of new values in future writes. *)
let mutable_mode m0 : _ Mode.Value.t =
{ comonadic = m0
; monadic = Mode.Value.Monadic.(min |> allow_left |> allow_right)