flambda-backend: Add val_modalities (ocaml-flambda#2685)

lambda/lambda.ml

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

lambda/lambda.mli

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

ocamldoc/odoc_sig.ml

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

testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference

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

testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference

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

testsuite/tests/typing-local/local.ml

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

testsuite/tests/typing-modes/def_nonportable.ml

@@ -0,0 +1 @@
+let (f @ nonportable) x = x

testsuite/tests/typing-modes/def_portable.ml

@@ -0,0 +1 @@
+let f x = x

testsuite/tests/typing-modes/modes.ml

@@ -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"
@@ -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
 |}]

testsuite/tests/typing-modes/module.ml

@@ -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 _ -> ()
 
@@ -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

testsuite/tests/typing-modes/mutable.ml

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

testsuite/tests/typing-modes/use_portable.bad.reference

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

testsuite/tests/typing-modes/use_portable.ml

@@ -0,0 +1,3 @@
+let portable_use : _ @ portable -> _ = fun _ -> ()
+
+let () = portable_use Maybe_portable.f