Fix external-external signature inclusion

Signature inclusion between two external declarations needs to be
aware of polymorphic modes when comparing the underlying primitives.

Author: stedolan

testsuite/tests/typing-local/local.ml

@@ -1630,11 +1630,20 @@ Error: This value escapes its region
 
 (* Poly-moded eta expansion *)
 module Heap32 : sig val add : int32 -> int32 -> int32 end = Int32
+module Heap32E : sig external add : int32 -> int32 -> int32 = "%int32_add" end = Int32
 module Local32 : sig val add : local_ int32 -> local_ int32 -> local_ int32 end = Int32
+module Local32E : sig external add : local_ int32 -> local_ int32 -> local_ int32 = "%int32_add" end = Int32
 [%%expect{|
 module Heap32 : sig val add : int32 -> int32 -> int32 end
+module Heap32E :
+  sig external add : int32 -> int32 -> int32 = "%int32_add" end
 module Local32 :
   sig val add : local_ int32 -> local_ int32 -> local_ int32 end
+module Local32E :
+  sig
+    external add : local_ int32 -> local_ int32 -> local_ int32
+      = "%int32_add"
+  end
 |}]
 module Bad32 : sig val add : local_ int32 -> local_ int32 -> int32 end =
   struct let add = Int32.add end

typing/includecore.ml

@@ -36,17 +36,27 @@ let value_descriptions ~loc env name
   match vd1.val_kind with
   | Val_prim p1 ->
      let ty1, mode1 = Ctype.instance_prim_mode p1 vd1.val_type in
-     if Ctype.moregeneral env true ty1 vd2.val_type then begin
-       match vd2.val_kind with
-           Val_prim p2 ->
-             if p1 = p2 then Tcoerce_none else raise Dont_match
-         | _ ->
-             let pc =
-               {pc_desc = p1; pc_type = vd2.Types.val_type; pc_poly_mode = mode1;
-                pc_env = env; pc_loc = vd1.Types.val_loc; } in
-             Tcoerce_primitive pc
-     end else
-       raise Dont_match
+     begin match vd2.val_kind with
+     | Val_prim p2 ->
+        let ty2, _mode2 = Ctype.instance_prim_mode p2 vd2.val_type in
+        if not (Ctype.moregeneral env true ty1 ty2) then
+          raise Dont_match;
+        let mode1 : Primitive.mode =
+          match Btype.Alloc_mode.check_const mode1 with
+          | Some Global -> Prim_global
+          | Some Local -> Prim_local
+          | None -> Prim_poly
+        in
+        let p1 = Primitive.inst_mode mode1 p1 in
+        if p1 = p2 then Tcoerce_none else raise Dont_match
+     | _ ->
+        if not (Ctype.moregeneral env true ty1 vd2.val_type) then
+          raise Dont_match;
+        let pc =
+          {pc_desc = p1; pc_type = vd2.Types.val_type; pc_poly_mode = mode1;
+           pc_env = env; pc_loc = vd1.Types.val_loc; } in
+        Tcoerce_primitive pc
+     end
   | _ ->
      if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
        match vd2.val_kind with

typing/primitive.ml

@@ -275,6 +275,15 @@ let native_name_is_external p =
   let nat_name = native_name p in
   nat_name <> "" && nat_name.[0] <> '%'
 
+let inst_mode mode p =
+  let inst_repr = function
+    | Prim_poly, r -> mode, r
+    | (Prim_global|Prim_local) as m, r -> m, r
+  in
+  { p with
+    prim_native_repr_args = List.map inst_repr p.prim_native_repr_args;
+    prim_native_repr_res = inst_repr p.prim_native_repr_res }
+
 let report_error ppf err =
   match err with
   | Old_style_float_with_native_repr_attribute ->

typing/primitive.mli

@@ -88,6 +88,8 @@ val byte_name: description -> string
     compiler itself. *)
 val native_name_is_external : description -> bool
 
+val inst_mode : mode -> description -> description
+
 type error =
   | Old_style_float_with_native_repr_attribute
   | Old_style_noalloc_with_noalloc_attribute