Implement let mutable

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);
 

jane/doc/extensions/_08-miscellaneous-extensions/let-mutable.md

@@ -0,0 +1,35 @@
+# The `let mutable` extension
+
+The `let mutable` extension provides a new type of `let` statement which
+declares a stack-local variable. It can be thought of as an unboxed `ref`.
+
+```ocaml
+let triangle n =
+  let mutable total = 0 in
+  for i = 1 to n do
+    total <- total + i
+  done;
+  total
+```
+
+Mutable variables must not escape their scope. For example, you can't
+return a closure that closes over a mutable variable. At the moment, the mode
+checker is, sadly, not sophisticated enough to allow some constructions which
+are obviously safe. For example, the following code is safe, but rejected by the
+mode checker.
+
+```ocaml
+let sum xs =
+  let mutable total = 0 in
+  List.iter xs ~f:(fun x -> total <- total + x);
+  total
+```
+
+
+## Restrictions
+
+Mutable `let` declarations may not be recursive, and they may not be used at the
+structure level or in class definitions. The pattern of a mutable `let`
+statement must be a single variable, possibly with a type annotation, e.g. `let
+mutable x, y = ..` and `let mutable add x y = ..` are not allowed. Mutable `let`
+statements must also not use `and`s.

lambda/matching.ml

@@ -4270,7 +4270,7 @@ let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam =
   in
   List.fold_left push_sublet exit rev_sublets
 
-let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
+let for_let ~scopes ~arg_sort ~return_layout loc param mutable_flag pat body =
   match pat.pat_desc with
   | Tpat_any ->
       (* This eliminates a useless variable (and stack slot in bytecode)
@@ -4286,7 +4286,10 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
          non-polymorphic Ppat_constraint case in type_pat_aux.
       *)
       let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in
-      Llet (Strict, k, id, duid, param, body)
+      begin match mutable_flag with
+      | Asttypes.Mutable -> Lmutlet (k, id, duid, param, body)
+      | Asttypes.Immutable -> Llet (Strict, k, id, duid, param, body)
+      end
   | _ ->
       let opt = ref false in
       let nraise = next_raise_count () in
@@ -4510,7 +4513,7 @@ let for_optional_arg_default
             Loc_unknown))
   in
   for_let ~scopes ~arg_sort:default_arg_sort ~return_layout
-    loc supplied_or_default pat body
+    loc supplied_or_default Immutable pat body
 
 (* Error report *)
 (* CR layouts v5: This file didn't use to have the report_error infrastructure -

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 ->

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 }

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

lambda/translcore.ml

@@ -392,6 +392,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       let return_layout = layout_exp sort body in
       transl_let ~scopes ~return_layout rec_flag pat_expr_list
         (event_before ~scopes body (transl_exp ~scopes sort body))
+  | Texp_letmutable(pat_expr, body) ->
+      let return_layout = layout_exp sort body in
+      transl_letmutable ~scopes ~return_layout pat_expr
+        (event_before ~scopes body (transl_exp ~scopes sort body))
   | Texp_function { params; body; ret_sort; ret_mode; alloc_mode;
                     zero_alloc } ->
       let ret_sort = Jkind.Sort.default_for_transl_and_get ret_sort in
@@ -950,11 +954,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       let self = transl_value_path loc e.exp_env path_self in
       let var = transl_value_path loc e.exp_env path in
       Lprim(Pfield_computed Reads_vary, [self; var], loc)
+  | Texp_mutvar id -> Lmutvar id.txt
   | Texp_setinstvar(path_self, path, _, expr) ->
       let loc = of_location ~scopes e.exp_loc in
       let self = transl_value_path loc e.exp_env path_self in
       let var = transl_value_path loc e.exp_env path in
       transl_setinstvar ~scopes loc self var expr
+  | Texp_setmutvar(id, expr_sort, expr) ->
+      Lassign(id.txt, transl_exp ~scopes
+        (Jkind.Sort.default_for_transl_and_get expr_sort) expr)
   | Texp_override(path_self, modifs) ->
       let loc = of_location ~scopes e.exp_loc in
       let self = transl_value_path loc e.exp_env path_self in
@@ -1877,7 +1885,7 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false)
           let mk_body = transl rem in
           fun body ->
             Matching.for_let ~scopes ~arg_sort:sort ~return_layout pat.pat_loc
-              lam pat (mk_body body)
+              lam Immutable pat (mk_body body)
       in
       transl pat_expr_list
   | Recursive ->
@@ -1901,6 +1909,15 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false)
       let lam_bds = List.map2 transl_case pat_expr_list idlist in
       fun body -> Value_rec_compiler.compile_letrec lam_bds body
 
+and transl_letmutable ~scopes ~return_layout
+      {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc; vb_sort} body =
+  let arg_sort = Jkind_types.Sort.default_to_value_and_get vb_sort in
+  let lam =
+    transl_bound_exp ~scopes ~in_structure:false pat arg_sort expr vb_loc attr
+  in
+  Matching.for_let ~scopes ~return_layout ~arg_sort pat.pat_loc lam Mutable
+    pat body
+
 and transl_setinstvar ~scopes loc self var expr =
   let ptr_or_imm, _ = maybe_pointer expr in
   Lprim(Psetfield_computed (ptr_or_imm, Assignment modify_heap),

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))

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

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)

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

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

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

parsing/language_extension.ml

@@ -74,6 +74,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Small_numbers -> (module Maturity)
   | Instances -> (module Unit)
   | Separability -> (module Unit)
+  | Let_mutable -> (module Unit)
 
 (* We'll do this in a more principled way later. *)
 (* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
@@ -87,7 +88,7 @@ let is_erasable : type a. a t -> bool = function
   | Mode | Unique | Overwriting | Layouts -> true
   | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
   | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances
-  | Separability ->
+  | Separability | Let_mutable ->
     false
 
 let maturity_of_unique_for_drf = Stable
@@ -112,6 +113,7 @@ module Exist_pair = struct
     | Pair (Small_numbers, m) -> m
     | Pair (Instances, ()) -> Stable
     | Pair (Separability, ()) -> Stable
+    | Pair (Let_mutable, ()) -> Stable
 
   let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext
 
@@ -125,7 +127,7 @@ module Exist_pair = struct
     | Pair
         ( (( Comprehensions | Include_functor | Polymorphic_parameters
            | Immutable_arrays | Module_strengthening | Labeled_tuples
-           | Instances | Overwriting | Separability ) as ext),
+           | Instances | Overwriting | Separability | Let_mutable ) as ext),
           _ ) ->
       to_string ext
 
@@ -157,6 +159,7 @@ module Exist_pair = struct
     | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta))
     | "instances" -> Some (Pair (Instances, ()))
     | "separability" -> Some (Pair (Separability, ()))
+    | "let_mutable" -> Some (Pair (Let_mutable, ()))
     | _ -> None
 end
 
@@ -178,7 +181,8 @@ let all_extensions =
     Pack Labeled_tuples;
     Pack Small_numbers;
     Pack Instances;
-    Pack Separability ]
+    Pack Separability;
+    Pack Let_mutable ]
 
 (**********************************)
 (* string conversions *)
@@ -218,10 +222,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option =
   | Small_numbers, Small_numbers -> Some Refl
   | Instances, Instances -> Some Refl
   | Separability, Separability -> Some Refl
+  | Let_mutable, Let_mutable -> Some Refl
   | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
       | Polymorphic_parameters | Immutable_arrays | Module_strengthening
       | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances
-      | Separability ),
+      | Separability | Let_mutable ),
       _ ) ->
     None
 

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. *)

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