Only vary yielding with [@local_opt]

Author: d-kalinichenko

testsuite/tests/typing-modes/yielding.ml

@@ -126,6 +126,50 @@ let _ = with_global_effect (fun k -> let _ = Mk4 k in ())
 - : unit = ()
 |}]
 
+(* Externals and [yielding]: *)
+
+external ok_yielding : 'a @ local -> unit = "%ignore"
+
+let _ = ok_yielding 4
+
+let _ = ok_yielding (stack_ (Some "local string"))
+
+let _ = with_global_effect (fun k -> ok_yielding k)
+
+[%%expect{|
+external ok_yielding : local_ 'a -> unit = "%ignore"
+- : unit = ()
+- : unit = ()
+- : unit = ()
+|}]
+
+external requires_unyielding : 'a @ local unyielding -> unit = "%ignore"
+
+let _ = requires_unyielding 4
+
+let _ = requires_unyielding (stack_ (Some "local string"))
+
+let _ = with_global_effect (fun k -> requires_unyielding k)
+
+[%%expect{|
+external requires_unyielding : local_ 'a @ unyielding -> unit = "%ignore"
+- : unit = ()
+- : unit = ()
+Line 7, characters 57-58:
+7 | let _ = with_global_effect (fun k -> requires_unyielding k)
+                                                             ^
+Error: This value is "yielding" but expected to be "unyielding".
+|}]
+
+external returns_unyielding : 'a -> 'a @ local unyielding = "%identity"
+
+let _ = requires_unyielding (returns_unyielding "some string")
+
+[%%expect{|
+external returns_unyielding : 'a -> local_ 'a @ unyielding = "%identity"
+- : unit = ()
+|}]
+
 (* [@local_opt] and [yielding]: *)
 
 external id : ('a[@local_opt]) -> ('a[@local_opt]) = "%identity"

typing/ctype.ml

@@ -1663,14 +1663,12 @@ let instance_label ~fixed lbl =
   )
 
 (* CR dkalinichenko: we must vary yieldingness together with locality to get
-   sane behavior around defaults. Remove once we have mode polymorphism. *)
+   sane behavior around [@local_opt]. Remove once we have mode polymorphism. *)
 let prim_mode mvar mvar' = function
   | Primitive.Prim_global, _ ->
-    Locality.allow_right Locality.global,
-    Yielding.allow_right Yielding.unyielding
+    Locality.allow_right Locality.global, Yielding.newvar ()
   | Primitive.Prim_local, _ ->
-    Locality.allow_right Locality.local,
-    Yielding.allow_right Yielding.yielding
+    Locality.allow_right Locality.local, Yielding.newvar ()
   | Primitive.Prim_poly, _ ->
     match mvar, mvar' with
     | Some mvar, Some mvar' -> mvar, mvar'