Skip to content

Commit

Permalink
Add val_modalities (#2685)
Browse files Browse the repository at this point in the history
  • Loading branch information
riaqn authored Jun 29, 2024
1 parent 85e722c commit ce9d04f
Show file tree
Hide file tree
Showing 47 changed files with 1,120 additions and 269 deletions.
1 change: 1 addition & 0 deletions chamelon/compat.jst.ml
Original file line number Diff line number Diff line change
Expand Up @@ -400,6 +400,7 @@ let mk_value_description ~val_type ~val_kind ~val_attributes =
val_type;
val_kind;
val_loc = Location.none;
val_modalities = Mode.Modality.Value.id;
val_attributes;
val_uid = Uid.internal_not_actually_unique;
val_zero_alloc = Default_zero_alloc;
Expand Down
1 change: 1 addition & 0 deletions native_toplevel/opttoploop.ml
Original file line number Diff line number Diff line change
Expand Up @@ -345,6 +345,7 @@ let name_expression ~loc ~attrs sort exp =
val_loc = loc;
val_attributes = attrs;
val_zero_alloc = Default_zero_alloc;
val_modalities = Mode.Modality.Value.id;
val_uid = Uid.internal_not_actually_unique; }
in
let sg = [Sig_value(id, vd, Exported)] in
Expand Down
20 changes: 15 additions & 5 deletions ocaml/lambda/lambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1398,16 +1398,26 @@ let build_substs update_env ?(freshen_bound_variables = false) s =
| Levent (lam, evt) ->
let old_env = evt.lev_env in
let env_updates =
let find_in_old id = Env.find_value (Path.Pident id) old_env in
let find_in_old id =
(* Looking up [id] might encounter locks, which we shouldn't apply
as we are not using the values. But adding the value to [new_env]
with the unlocked mode is just wrong. Therefore, we set the mode
to be [max] for conservative soundness. [new_env] is only used
for printing in debugger. *)
let vd = Env.find_value (Path.Pident id) old_env in
let vd = {vd with val_modalities = Mode.Modality.Value.id} in
let mode = Mode.Value.max |> Mode.Value.disallow_right in
(vd, mode)
in
let rebind id id' new_env =
match find_in_old id with
| exception Not_found -> new_env
| vd -> Env.add_value_lazy ~mode:Mode.Value.max id' vd new_env
| (vd, mode) -> Env.add_value_lazy ~mode id' vd new_env
in
let update_free id new_env =
match find_in_old id with
| exception Not_found -> new_env
| vd -> update_env id vd new_env
| vd_mode -> update_env id vd_mode new_env
in
Ident.Map.merge (fun id bound free ->
match bound, free with
Expand Down Expand Up @@ -1447,9 +1457,9 @@ let subst update_env ?freshen_bound_variables s =
(build_substs update_env ?freshen_bound_variables s).subst_lambda

let rename idmap lam =
let update_env oldid vd env =
let update_env oldid (vd, mode) env =
let newid = Ident.Map.find oldid idmap in
Env.add_value_lazy ~mode:Mode.Value.max newid vd env
Env.add_value_lazy ~mode newid vd env
in
let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in
subst update_env s lam
Expand Down
2 changes: 1 addition & 1 deletion ocaml/lambda/lambda.mli
Original file line number Diff line number Diff line change
Expand Up @@ -850,7 +850,7 @@ val flat_read_float_boxed : alloc_mode -> flat_element_read
val make_sequence: ('a -> lambda) -> 'a list -> lambda

val subst:
(Ident.t -> Subst.Lazy.value_description -> Env.t -> Env.t) ->
(Ident.t -> Subst.Lazy.value_description * Mode.Value.l -> Env.t -> Env.t) ->
?freshen_bound_variables:bool ->
lambda Ident.Map.t -> lambda -> lambda
(** [subst update_env ?freshen_bound_variables s lt]
Expand Down
2 changes: 1 addition & 1 deletion ocaml/ocamldoc/odoc_sig.ml
Original file line number Diff line number Diff line change
Expand Up @@ -492,7 +492,7 @@ module Analyser =
let record comments
{ Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
get_field env comments @@
{Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Value.id;
{Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Value.Const.id;
ld_jkind=Jkind.Primitive.any ~why:Dummy_jkind (* ignored *);
ld_type=ld_type.Typedtree.ctyp_type;
ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<def_rec>
pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11])
Tpat_var "fib"
value_mode global,many,nonportable,shared,uncontended
value_mode global,many,nonportable;join(shared,contended)(modevar#1[shared,uncontended .. unique,uncontended])
expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
Texp_function
region true
alloc_mode global,many,nonportable,shared,uncontended
alloc_mode global,many,nonportable;id(modevar#7[shared,contended .. unique,uncontended])
[]
Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
alloc_mode global,many,nonportable,shared,uncontended
alloc_mode global,many,nonportable;shared,uncontended
value
[
<case>
Expand All @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<case>
pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5])
Tpat_var "n"
value_mode global,many,portable,unique,uncontended
value_mode global,many,portable;unique,uncontended
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34])
Texp_apply
apply_mode Tail
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<def_rec>
pattern
Tpat_var "fib"
value_mode global,many,nonportable,shared,uncontended
value_mode global,many,nonportable;join(shared,contended)(modevar#1[shared,uncontended .. unique,uncontended])
expression
Texp_function
region true
alloc_mode global,many,nonportable,shared,uncontended
alloc_mode global,many,nonportable;id(modevar#7[shared,contended .. unique,uncontended])
[]
Tfunction_cases
alloc_mode global,many,nonportable,shared,uncontended
alloc_mode global,many,nonportable;shared,uncontended
value
[
<case>
Expand All @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<case>
pattern
Tpat_var "n"
value_mode global,many,portable,unique,uncontended
value_mode global,many,portable;unique,uncontended
expression
Texp_apply
apply_mode Tail
Expand Down
12 changes: 6 additions & 6 deletions ocaml/testsuite/tests/typing-local/local.ml
Original file line number Diff line number Diff line change
Expand Up @@ -902,7 +902,7 @@ module type T = sig val x : int option end
Line 4, characters 50-51:
4 | let _m : (module T) = local_ (module struct let x = thing end) in
^
Error: This value escapes its region.
Error: This value is local, but expected to be global because it is inside a module.
|}]
let local_module () =
let thing = local_ Some 1 in
Expand All @@ -914,7 +914,7 @@ let local_module () =
Line 4, characters 30-31:
4 | let module M = struct let x = thing end in
^
Error: This value escapes its region.
Error: This value is local, but expected to be global because it is inside a module.
|}]
let obj () =
let thing = local_ Some 1 in
Expand Down Expand Up @@ -2150,10 +2150,10 @@ module M = struct
| (None, None, z) = (Some (ref 0), (local_ (Some (ref 0))), (ref 0))
end
[%%expect{|
Line 2, characters 35-36:
Line 2, characters 12-13:
2 | let (Some z, _, _) | (None, Some z, _)
^
Error: This value escapes its region.
^
Error: This value is local, but expected to be global because it is inside a module.
|}]
module M = struct
Expand All @@ -2164,7 +2164,7 @@ end
Line 2, characters 12-13:
2 | let (Some z, _, _) | (None, Some z, _)
^
Error: This value escapes its region.
Error: This value is local, but expected to be global because it is inside a module.
|}]
(* Example of backtracking after mode error *)
Expand Down
1 change: 1 addition & 0 deletions ocaml/testsuite/tests/typing-modes/def_nonportable.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
let (f @ nonportable) x = x
1 change: 1 addition & 0 deletions ocaml/testsuite/tests/typing-modes/def_portable.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
let f x = x
24 changes: 13 additions & 11 deletions ocaml/testsuite/tests/typing-modes/modes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -385,16 +385,7 @@ let foo () =
val foo : unit -> unit = <fun>
|}]

(* modalities on value descriptions are parsed and not type checked yet. *)
module type S = sig
val x : string -> string @ local @@ foo bar
end
[%%expect{|
Line 2, characters 38-41:
2 | val x : string -> string @ local @@ foo bar
^^^
Error: Modalities on value descriptions are not supported yet.
|}]
(* modalities on primitives are parsed but not supported yet. *)

module type S = sig
external x : string -> string @ local @@ foo bar = "%hello"
Expand All @@ -403,5 +394,16 @@ end
Line 2, characters 43-46:
2 | external x : string -> string @ local @@ foo bar = "%hello"
^^^
Error: Modalities on value descriptions are not supported yet.
Error: Modality on primitive is not supported yet.
|}]

(* modalities on normal values requires [-extension mode_alpha] *)
module type S = sig
val x : string -> string @ local @@ foo bar
end
[%%expect{|
Line 2, characters 38-41:
2 | val x : string -> string @ local @@ foo bar
^^^
Error: The extension "mode" is disabled and cannot be used
|}]
36 changes: 3 additions & 33 deletions ocaml/testsuite/tests/typing-modes/module.ml
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,9 @@
expect;
*)

(* This file tests that modules are sound wrt modes. *)
(* This file tests the legacy aspect of modules. The non-legacy aspects are
tested in [val_modalities.ml]. As we enrich modules with modes, this file
will shrink. *)

let portable_use : 'a @ portable -> unit = fun _ -> ()

Expand Down Expand Up @@ -72,38 +74,6 @@ Line 6, characters 17-20:
Error: This value is nonportable but expected to be portable.
|}]

(* Values in modules are defined as legacy *)
module M = struct
let x = local_ "hello"
end
[%%expect{|
Line 2, characters 8-9:
2 | let x = local_ "hello"
^
Error: This value escapes its region.
|}]

(* Values from modules are available as legacy *)
let u =
let foo () = M.x in
portable_use foo
[%%expect{|
Line 3, characters 17-20:
3 | portable_use foo
^^^
Error: This value is nonportable but expected to be portable.
|}]

let u =
let foo () = List.length in
portable_use foo
[%%expect{|
Line 3, characters 17-20:
3 | portable_use foo
^^^
Error: This value is nonportable but expected to be portable.
|}]

let u =
let foo () =
let m = (module struct let x _ = () end : S) in
Expand Down
2 changes: 1 addition & 1 deletion ocaml/testsuite/tests/typing-modes/mutable.ml
Original file line number Diff line number Diff line change
Expand Up @@ -167,7 +167,7 @@ let r @ portable =
(* CR mode-crossing: The [m0] in mutable corresponds to the field type wrapped
in modality; as a result, it enjoys mode crossing enabled by the modality. *)
[%%expect{|
type r = { f : string -> string; mutable g : string -> string; }
type r = { f : string -> string; mutable g : string -> string @@ portable; }
Lines 5-6, characters 2-20:
5 | ..{ f = (fun x -> x);
6 | g = fun x -> x }
Expand Down
4 changes: 4 additions & 0 deletions ocaml/testsuite/tests/typing-modes/use_portable.bad.reference
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
File "use_portable.ml", line 3, characters 22-38:
3 | let () = portable_use Maybe_portable.f
^^^^^^^^^^^^^^^^
Error: This value is nonportable but expected to be portable.
3 changes: 3 additions & 0 deletions ocaml/testsuite/tests/typing-modes/use_portable.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
let portable_use : _ @ portable -> _ = fun _ -> ()

let () = portable_use Maybe_portable.f
Loading

0 comments on commit ce9d04f

Please sign in to comment.