Skip to content

Implement let mutable #3964

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 8 commits into
base: main
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 5 additions & 3 deletions file_formats/cmt_format.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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);

Expand Down
9 changes: 6 additions & 3 deletions lambda/matching.ml
Original file line number Diff line number Diff line change
Expand Up @@ -4245,7 +4245,7 @@ let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam =
in
List.fold_left push_sublet exit rev_sublets

let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
let for_let ~scopes ~arg_sort ~return_layout loc param mutable_flag pat body =
match pat.pat_desc with
| Tpat_any ->
(* This eliminates a useless variable (and stack slot in bytecode)
Expand All @@ -4261,7 +4261,10 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
non-polymorphic Ppat_constraint case in type_pat_aux.
*)
let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in
Llet (Strict, k, id, param, body)
begin match mutable_flag with
| Asttypes.Mutable -> Lmutlet (k, id, param, body)
| Asttypes.Immutable -> Llet (Strict, k, id, param, body)
end
| _ ->
let opt = ref false in
let nraise = next_raise_count () in
Expand Down Expand Up @@ -4480,7 +4483,7 @@ let for_optional_arg_default
Loc_unknown))
in
for_let ~scopes ~arg_sort:default_arg_sort ~return_layout
loc supplied_or_default pat body
loc supplied_or_default Immutable pat body

(* Error report *)
(* CR layouts v5: This file didn't use to have the report_error infrastructure -
Expand Down
2 changes: 1 addition & 1 deletion lambda/matching.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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 ->
Expand Down
2 changes: 1 addition & 1 deletion lambda/transl_array_comprehension.ml
Original file line number Diff line number Diff line change
Expand Up @@ -502,7 +502,7 @@ let iterator ~transl_exp ~scopes ~loc :
iter_arr_mut ),
[iter_arr.var; Lvar iter_ix],
loc ))
pattern body
Immutable pattern body
}
in
mk_iterator, Array { iter_arr; iter_len }
Expand Down
3 changes: 2 additions & 1 deletion lambda/transl_list_comprehension.ml
Original file line number Diff line number Diff line change
Expand Up @@ -198,7 +198,8 @@ let iterator ~transl_exp ~scopes = function
add_bindings =
(* CR layouts: to change when we allow non-values in sequences *)
Matching.for_let ~scopes ~arg_sort:Jkind.Sort.Const.for_list_element
~return_layout:layout_any_value pattern.pat_loc (Lvar element) pattern
~return_layout:layout_any_value pattern.pat_loc (Lvar element)
Immutable pattern
}

(** Translates a list comprehension binding
Expand Down
20 changes: 19 additions & 1 deletion lambda/translcore.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -948,11 +952,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
let self = transl_value_path loc e.exp_env path_self in
let var = transl_value_path loc e.exp_env path in
Lprim(Pfield_computed Reads_vary, [self; var], loc)
| Texp_mutvar id -> Lmutvar id.txt
| 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
Expand Down Expand Up @@ -1856,7 +1864,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 ->
Expand All @@ -1880,6 +1888,16 @@ 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
let lam = Translattribute.add_function_attributes lam 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),
Expand Down
4 changes: 2 additions & 2 deletions parsing/ast_helper.ml
Original file line number Diff line number Diff line change
Expand Up @@ -209,7 +209,7 @@ module Exp = struct

let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
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))
Expand All @@ -233,7 +233,7 @@ module Exp = struct
let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setvar (a, b))
let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
Expand Down
4 changes: 2 additions & 2 deletions parsing/ast_helper.mli
Original file line number Diff line number Diff line change
Expand Up @@ -149,8 +149,8 @@ module Exp:

val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
val let_: ?loc:loc -> ?attrs:attrs -> 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
Expand Down
2 changes: 1 addition & 1 deletion parsing/ast_invariants.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
4 changes: 2 additions & 2 deletions parsing/ast_iterator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -460,7 +460,7 @@ module E = struct
match desc with
| Pexp_ident x -> iter_loc sub x
| Pexp_constant _ -> ()
| Pexp_let (_r, vbs, e) ->
| Pexp_let (_m, _r, vbs, e) ->
List.iter (sub.value_binding sub) vbs;
sub.expr sub e
| Pexp_function (params, constraint_, body) ->
Expand Down Expand Up @@ -508,7 +508,7 @@ module E = struct
sub.modes sub m
| Pexp_send (e, _s) -> sub.expr sub e
| Pexp_new lid -> iter_loc sub lid
| Pexp_setinstvar (s, e) ->
| Pexp_setvar (s, e) ->
iter_loc sub s; sub.expr sub e
| Pexp_override sel ->
List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
Expand Down
6 changes: 3 additions & 3 deletions parsing/ast_mapper.ml
Original file line number Diff line number Diff line change
Expand Up @@ -529,8 +529,8 @@ module E = struct
match desc with
| Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x)
| 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
Expand Down Expand Up @@ -583,7 +583,7 @@ module E = struct
| Pexp_send (e, s) ->
send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
| Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
| Pexp_setinstvar (s, e) ->
| Pexp_setvar (s, e) ->
setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
| Pexp_override sel ->
override ~loc ~attrs
Expand Down
4 changes: 2 additions & 2 deletions parsing/depend.ml
Original file line number Diff line number Diff line change
Expand Up @@ -239,7 +239,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
Expand Down Expand Up @@ -275,7 +275,7 @@ let rec add_expr bv exp =
Option.iter (add_type bv) ty2
| Pexp_send(e, _m) -> add_expr bv e
| Pexp_new li -> add bv li
| Pexp_setinstvar(_v, e) -> add_expr bv e
| Pexp_setvar(_v, e) -> add_expr bv e
| Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in
Expand Down
15 changes: 11 additions & 4 deletions parsing/language_extension.ml
Original file line number Diff line number Diff line change
Expand Up @@ -73,6 +73,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
| Labeled_tuples -> (module Unit)
| Small_numbers -> (module Maturity)
| Instances -> (module Unit)
| Let_mutable -> (module Unit)

(* We'll do this in a more principled way later. *)
(* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
Expand All @@ -85,7 +86,8 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
let is_erasable : type a. a t -> bool = function
| Mode | Unique | Overwriting | Layouts -> true
| Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
| Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances ->
| Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances
| Let_mutable ->
false

let maturity_of_unique_for_drf = Stable
Expand All @@ -109,6 +111,7 @@ module Exist_pair = struct
| Pair (Labeled_tuples, ()) -> Stable
| Pair (Small_numbers, m) -> m
| Pair (Instances, ()) -> Stable
| Pair (Let_mutable, ()) -> Beta

let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext

Expand All @@ -122,7 +125,7 @@ module Exist_pair = struct
| Pair
( (( Comprehensions | Include_functor | Polymorphic_parameters
| Immutable_arrays | Module_strengthening | Labeled_tuples
| Instances | Overwriting ) as ext),
| Instances | Overwriting | Let_mutable ) as ext),
_ ) ->
to_string ext

Expand Down Expand Up @@ -153,6 +156,7 @@ module Exist_pair = struct
| "small_numbers" -> Some (Pair (Small_numbers, Stable))
| "small_numbers_beta" -> Some (Pair (Small_numbers, Beta))
| "instances" -> Some (Pair (Instances, ()))
| "let_mutable" -> Some (Pair (Let_mutable, ()))
| _ -> None
end

Expand All @@ -173,7 +177,8 @@ let all_extensions =
Pack SIMD;
Pack Labeled_tuples;
Pack Small_numbers;
Pack Instances ]
Pack Instances;
Pack Let_mutable ]

(**********************************)
(* string conversions *)
Expand Down Expand Up @@ -212,9 +217,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option =
| Labeled_tuples, Labeled_tuples -> Some Refl
| Small_numbers, Small_numbers -> Some Refl
| Instances, Instances -> Some Refl
| Let_mutable, Let_mutable -> Some Refl
| ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
| Polymorphic_parameters | Immutable_arrays | Module_strengthening
| Layouts | SIMD | Labeled_tuples | Small_numbers | Instances ),
| Layouts | SIMD | Labeled_tuples | Small_numbers | Instances
| Let_mutable ),
_ ) ->
None

Expand Down
1 change: 1 addition & 0 deletions parsing/language_extension.mli
Original file line number Diff line number Diff line change
Expand Up @@ -31,6 +31,7 @@ type 'a t = 'a Language_extension_kernel.t =
| Labeled_tuples : unit t
| Small_numbers : maturity t
| Instances : unit t
| Let_mutable : unit t

(** Require that an extension is enabled for at least the provided level, or
else throw an exception at the provided location saying otherwise. *)
Expand Down
8 changes: 8 additions & 0 deletions parsing/parse.ml
Original file line number Diff line number Diff line change
Expand Up @@ -178,6 +178,14 @@ let prepare_error err =
| Malformed_instance_identifier loc ->
Location.errorf ~loc
"Syntax error: Unexpected in module instance"
| Let_mutable_not_allowed_at_structure_level loc ->
Location.errorf ~loc
"Syntax error: Mutable let bindings are not allowed \
at the structure level"
| Let_mutable_not_allowed_in_class_definition loc ->
Location.errorf ~loc
"Syntax error: Mutable let bindings are not allowed \
inside class definitions"

let () =
Location.register_error_of_exn
Expand Down
17 changes: 13 additions & 4 deletions parsing/parser.mly
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -689,6 +690,9 @@ let val_of_let_bindings ~loc lbs =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
if lbs.lbs_mutable = Mutable
then raise (Syntaxerr.Error
(Syntaxerr.Let_mutable_not_allowed_at_structure_level (make_loc loc)));
let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
match lbs.lbs_extension with
| None -> str
Expand All @@ -703,7 +707,8 @@ let expr_of_let_bindings ~loc lbs body =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
mkexp_attrs ~loc
(Pexp_let(lbs.lbs_mutable, lbs.lbs_rec, List.rev bindings, body))
(lbs.lbs_extension, [])

let class_of_let_bindings ~loc lbs body =
Expand All @@ -715,6 +720,9 @@ let class_of_let_bindings ~loc lbs body =
?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
if lbs.lbs_mutable = Mutable
then raise (Syntaxerr.Error
(Syntaxerr.Let_mutable_not_allowed_in_class_definition (make_loc loc)));
(* Our use of let_bindings(no_ext) guarantees the following: *)
assert (lbs.lbs_extension = None);
mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
Expand Down Expand Up @@ -2805,7 +2813,7 @@ fun_expr:
{ mkexp_cons ~loc:$sloc $loc($2)
(ghexp ~loc:$sloc (Pexp_tuple[None, $1;None, $3])) }
| mkrhs(label) LESSMINUS expr
{ mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
{ mkexp ~loc:$sloc (Pexp_setvar($1, $3)) }
| simple_expr DOT mkrhs(label_longident) LESSMINUS expr
{ mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
| indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v})
Expand Down Expand Up @@ -3230,12 +3238,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:
Expand Down
1 change: 1 addition & 0 deletions parsing/parser_types.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 }
1 change: 1 addition & 0 deletions parsing/parser_types.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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 }
Loading
Loading