fix the issue with instance_prim

Author: d-kalinichenko

typing/ctype.ml

@@ -1806,14 +1806,14 @@ let instance_prim_mode (desc : Primitive.description) ty =
     let finalret = prim_mode (Some mode_l) (Some mode_y) desc.prim_native_repr_res in
     instance_prim_locals desc.prim_native_repr_args
       mode_l mode_y (Alloc.disallow_right Alloc.legacy) finalret ty,
-    Some mode_l
+    Some mode_l, Some mode_y
   else
-    ty, None
+    ty, None, None
 
 let instance_prim (desc : Primitive.description) ty =
   let ty, sort = instance_prim_layout desc ty in
-  let ty, mode = instance_prim_mode desc ty in
-  ty, mode, sort
+  let ty, mode_l, mode_y = instance_prim_mode desc ty in
+  ty, mode_l, mode_y, sort
 
 (**** Instantiation with parameter substitution ****)
 

typing/ctype.mli

@@ -229,7 +229,8 @@ val prim_mode :
          * (Mode.allowed * 'r) Mode.Yielding.t
 val instance_prim:
         Primitive.description -> type_expr ->
-        type_expr * Mode.Locality.lr option * Jkind.Sort.t option
+        type_expr * Mode.Locality.lr option
+        * Mode.Yielding.lr option * Jkind.Sort.t option
 
 (** Given (a @ m1 -> b -> c) @ m0, where [m0] and [m1] are modes expressed by
     user-syntax, [curry_mode m0 m1] gives the mode we implicitly interpret b->c

typing/includecore.ml

@@ -191,37 +191,37 @@ let value_descriptions ~loc env name
   | Val_prim p1 -> begin
      match vd2.val_kind with
      | Val_prim p2 -> begin
-         let ty1_global, _, _ = Ctype.instance_prim p1 vd1.val_type in
-         let ty2_global =
-           let ty2, mode2, _ = Ctype.instance_prim p2 vd2.val_type in
-           Option.iter
-             (fun m -> Mode.Locality.submode_exn m Mode.Locality.global)
-             mode2;
-           ty2
-         in
-         (try Ctype.moregeneral env true ty1_global ty2_global
-          with Ctype.Moregen err -> raise (Dont_match (Type err)));
-         let ty1_local, _, _ = Ctype.instance_prim p1 vd1.val_type in
-         let ty2_local =
-           let ty2, mode2, _ = Ctype.instance_prim p2 vd2.val_type in
-           Option.iter
-             (fun m -> Mode.Locality.submode_exn Mode.Locality.local m)
-             mode2;
-           ty2
-         in
-         (try Ctype.moregeneral env true ty1_local ty2_local
-          with Ctype.Moregen err -> raise (Dont_match (Type err)));
+         let restrict_locality = [
+           (fun m -> Mode.Locality.submode_exn m Mode.Locality.global);
+           (fun m -> Mode.Locality.submode_exn Mode.Locality.local m)
+         ] in
+         let restrict_yielding = [
+           (fun m -> Mode.Yielding.submode_exn m Mode.Yielding.unyielding);
+           (fun m -> Mode.Yielding.submode_exn Mode.Yielding.yielding m)
+         ] in
+         List.iter (fun restrict_loc ->
+           List.iter (fun restrict_yield ->
+             let ty1, _, _, _ = Ctype.instance_prim p1 vd1.val_type in
+             let ty2, mode_l2, mode_y2, _ = Ctype.instance_prim p2 vd2.val_type in
+             Option.iter restrict_loc mode_l2;
+             Option.iter restrict_yield mode_y2;
+             try 
+               Ctype.moregeneral env true ty1 ty2
+             with Ctype.Moregen err -> 
+               raise (Dont_match (Type err))
+           ) restrict_yielding
+         ) restrict_locality;
          match primitive_descriptions p1 p2 with
          | None -> Tcoerce_none
          | Some err -> raise (Dont_match (Primitive_mismatch err))
        end
      | _ ->
-        let ty1, mode1, sort1 = Ctype.instance_prim p1 vd1.val_type in
+        let ty1, mode_l1, _, sort1 = Ctype.instance_prim p1 vd1.val_type in
         (try Ctype.moregeneral env true ty1 vd2.val_type
          with Ctype.Moregen err -> raise (Dont_match (Type err)));
         let pc =
           {pc_desc = p1; pc_type = vd2.Types.val_type;
-           pc_poly_mode = Option.map Mode.Locality.disallow_right mode1;
+           pc_poly_mode = Option.map Mode.Locality.disallow_right mode_l1;
            pc_poly_sort=sort1;
            pc_env = env; pc_loc = vd1.Types.val_loc; } in
         Tcoerce_primitive pc

typing/typecore.ml

@@ -7132,7 +7132,7 @@ and type_ident env ?(recarg=Rejected) lid =
   let val_type, kind =
     match desc.val_kind with
     | Val_prim prim ->
-       let ty, mode, sort = instance_prim prim desc.val_type in
+       let ty, mode, _, sort = instance_prim prim desc.val_type in
        let ty = instance ty in
        begin match prim.prim_native_repr_res, mode with
        (* if the locality of returned value of the primitive is poly