Yielding mode axis

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

@@ -89,13 +89,13 @@ 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;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended])
+          value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended])
         expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
           Texp_function
-          alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended])
+          alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended])
           []
           Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
-          alloc_mode global,many,nonportable;aliased,uncontended
+          alloc_mode global,many,nonportable,unyielding;aliased,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,unyielding;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

@@ -89,13 +89,13 @@ 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;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended])
+          value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended])
         expression 
           Texp_function
-          alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended])
+          alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended])
           []
           Tfunction_cases 
-          alloc_mode global,many,nonportable;aliased,uncontended
+          alloc_mode global,many,nonportable,unyielding;aliased,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,unyielding;unique,uncontended
                 expression 
                   Texp_apply
                   apply_mode Tail

testsuite/tests/typing-layouts/jkinds.ml

@@ -279,8 +279,8 @@ Error: Layout void is more experimental than allowed by the enabled layouts exte
 |}]
 
 type a : immediate
-type b : value mod global unique many uncontended portable external_ = a
-type c : value mod global unique many uncontended portable external_
+type b : value mod global unique many uncontended portable unyielding external_ = a
+type c : value mod global unique many uncontended portable unyielding external_
 type d : immediate = c
 [%%expect{|
 type a : immediate
@@ -290,8 +290,8 @@ type d = c
 |}]
 
 type a : immediate64
-type b : value mod global unique many uncontended portable external64 = a
-type c : value mod global unique many uncontended portable external64
+type b : value mod global unique many uncontended portable unyielding external64 = a
+type c : value mod global unique many uncontended portable unyielding external64
 type d : immediate64 = c
 [%%expect{|
 type a : immediate64

testsuite/tests/typing-modes/yielding.ml

@@ -0,0 +1,80 @@
+(* TEST
+ expect;
+*)
+
+(* CR dkalinichenko: allow [yielding] at toplevel? *)
+let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!"
+[%%expect{|
+Line 1, characters 4-72:
+1 | let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!"
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This value is "yielding" but expected to be "unyielding".
+|}]
+
+let storage = ref ""
+
+let with_effect : ((string -> unit) @ local yielding -> 'a) -> 'a =
+  fun f -> f ((:=) storage)
+
+[%%expect{|
+val storage : string ref = {contents = ""}
+val with_effect : (local_ (string -> unit) @ yielding -> 'a) -> 'a = <fun>
+|}]
+
+let () = with_effect (fun k -> k "Hello, world!")
+
+let _ = !storage
+
+[%%expect{|
+- : string = "Hello, world!"
+|}]
+
+let run_yielding : (string -> unit) @ local yielding -> unit = fun f -> f "my string"
+
+let () = with_effect (fun k -> run_yielding k)
+
+let _ = !storage
+
+[%%expect{|
+val run_yielding : local_ (string -> unit) @ yielding -> unit = <fun>
+- : string = "my string"
+|}]
+
+let run_unyielding : (string -> unit) @ local unyielding -> unit = fun f -> f "another string"
+
+let () = with_effect (fun k -> run_unyielding k)
+
+[%%expect{|
+val run_unyielding : local_ (string -> unit) -> unit = <fun>
+Line 3, characters 46-47:
+3 | let () = with_effect (fun k -> run_unyielding k)
+                                                  ^
+Error: This value is "yielding" but expected to be "unyielding".
+|}]
+
+(* CR dkalinichenko: default [local] arguments to [yielding]. *)
+
+let run_default : (string -> unit) @ local -> unit = fun f -> f "some string"
+
+let () = with_effect (fun k -> run_default k)
+
+[%%expect{|
+val run_default : local_ (string -> unit) -> unit = <fun>
+Line 3, characters 43-44:
+3 | let () = with_effect (fun k -> run_default k)
+                                               ^
+Error: This value is "yielding" but expected to be "unyielding".
+|}]
+
+(* A closure over a [yielding] value must be [yielding]. *)
+
+let () = with_effect (fun k ->
+  let closure @ local unyielding = fun () -> k () in
+  run_unyielding k)
+
+[%%expect{|
+Line 2, characters 45-46:
+2 |   let closure @ local unyielding = fun () -> k () in
+                                                 ^
+Error: The value "k" is yielding, so cannot be used inside a function that may not yield.
+|}]

typing/env.ml

@@ -4419,6 +4419,7 @@ let report_lookup_error _loc env ppf = function
         | Error (Areality, _) -> "local", "might escape"
         | Error (Linearity, _) -> "once", "is many"
         | Error (Portability, _) -> "nonportable", "is portable"
+        | Error (Yielding, _) -> "yielding", "may not yield"
       in
       let s, hint =
         match context with

typing/jkind.ml

@@ -436,7 +436,8 @@ module Const = struct
                 contention = Contention.Const.min;
                 portability = Portability.Const.min;
                 uniqueness = Uniqueness.Const.max;
-                areality = Locality.Const.max
+                areality = Locality.Const.max;
+                yielding = Yielding.Const.min
               };
             externality_upper_bound = Externality.max;
             nullability_upper_bound = Nullability.Non_null
@@ -452,7 +453,8 @@ module Const = struct
                 contention = Contention.Const.max;
                 portability = Portability.Const.min;
                 uniqueness = Uniqueness.Const.max;
-                areality = Locality.Const.max
+                areality = Locality.Const.max;
+                yielding = Yielding.Const.min
               };
             externality_upper_bound = Externality.max;
             nullability_upper_bound = Nullability.Non_null
@@ -774,7 +776,8 @@ module Const = struct
           linearity = parsed_modifiers.linearity;
           uniqueness = parsed_modifiers.uniqueness;
           portability = parsed_modifiers.portability;
-          contention = parsed_modifiers.contention
+          contention = parsed_modifiers.contention;
+          yielding = parsed_modifiers.yielding
         }
       in
       { layout = base.layout;
@@ -1165,7 +1168,8 @@ let for_arrow =
           areality = Locality.Const.max;
           uniqueness = Uniqueness.Const.min;
           portability = Portability.Const.max;
-          contention = Contention.Const.min
+          contention = Contention.Const.min;
+          yielding = Yielding.Const.max
         };
       externality_upper_bound = Externality.max;
       nullability_upper_bound = Non_null

typing/jkind_axis.ml

@@ -142,6 +142,7 @@ module Axis = struct
       | Uniqueness : Mode.Uniqueness.Const.t t
       | Portability : Mode.Portability.Const.t t
       | Contention : Mode.Contention.Const.t t
+      | Yielding : Mode.Yielding.Const.t t
   end
 
   module Nonmodal = struct
@@ -180,6 +181,8 @@ module Axis = struct
       (module Accent_lattice (Mode.Portability.Const) : Axis_s with type t = a)
     | Modal Contention ->
       (module Accent_lattice (Mode.Contention.Const) : Axis_s with type t = a)
+    | Modal Yielding ->
+      (module Accent_lattice (Mode.Yielding.Const) : Axis_s with type t = a)
     | Nonmodal Externality -> (module Externality : Axis_s with type t = a)
     | Nonmodal Nullability -> (module Nullability : Axis_s with type t = a)
 
@@ -189,6 +192,7 @@ module Axis = struct
       Pack (Modal Uniqueness);
       Pack (Modal Portability);
       Pack (Modal Contention);
+      Pack (Modal Yielding);
       Pack (Nonmodal Externality);
       Pack (Nonmodal Nullability) ]
 
@@ -198,6 +202,7 @@ module Axis = struct
     | Modal Uniqueness -> "uniqueness"
     | Modal Portability -> "portability"
     | Modal Contention -> "contention"
+    | Modal Yielding -> "yielding"
     | Nonmodal Externality -> "externality"
     | Nonmodal Nullability -> "nullability"
 end
@@ -210,6 +215,7 @@ module Axis_collection (T : Misc.T1) = struct
       uniqueness : Mode.Uniqueness.Const.t T.t;
       portability : Mode.Portability.Const.t T.t;
       contention : Mode.Contention.Const.t T.t;
+      yielding : Mode.Yielding.Const.t T.t;
       externality : Externality.t T.t;
       nullability : Nullability.t T.t
     }
@@ -221,6 +227,7 @@ module Axis_collection (T : Misc.T1) = struct
     | Modal Uniqueness -> values.uniqueness
     | Modal Portability -> values.portability
     | Modal Contention -> values.contention
+    | Modal Yielding -> values.yielding
     | Nonmodal Externality -> values.externality
     | Nonmodal Nullability -> values.nullability
 
@@ -231,6 +238,7 @@ module Axis_collection (T : Misc.T1) = struct
     | Modal Uniqueness -> { values with uniqueness = value }
     | Modal Portability -> { values with portability = value }
     | Modal Contention -> { values with contention = value }
+    | Modal Yielding -> { values with yielding = value }
     | Nonmodal Externality -> { values with externality = value }
     | Nonmodal Nullability -> { values with nullability = value }
 
@@ -246,6 +254,7 @@ module Axis_collection (T : Misc.T1) = struct
       uniqueness = f ~axis:Axis.(Modal Uniqueness);
       portability = f ~axis:Axis.(Modal Portability);
       contention = f ~axis:Axis.(Modal Contention);
+      yielding = f ~axis:Axis.(Modal Yielding);
       externality = f ~axis:Axis.(Nonmodal Externality);
       nullability = f ~axis:Axis.(Nonmodal Nullability)
     }

typing/jkind_axis.mli

@@ -64,6 +64,7 @@ module Axis : sig
       | Uniqueness : Mode.Uniqueness.Const.t t
       | Portability : Mode.Portability.Const.t t
       | Contention : Mode.Contention.Const.t t
+      | Yielding : Mode.Yielding.Const.t t
   end
 
   module Nonmodal : sig
@@ -98,6 +99,7 @@ module Axis_collection (T : Misc.T1) : sig
       uniqueness : Mode.Uniqueness.Const.t T.t;
       portability : Mode.Portability.Const.t T.t;
       contention : Mode.Contention.Const.t T.t;
+      yielding : Mode.Yielding.Const.t T.t;
       externality : Externality.t T.t;
       nullability : Nullability.t T.t
     }