Merge pull request #10539 from COCTI/revert_dup_kinds

 Field kinds should be kept when copying types

Changes

@@ -104,6 +104,12 @@ Working version
   otherwise the derived pointer is live across a poll point.
   (Vincent Laviron and Xavier Leroy, review by Xavier Leroy and Sadiq Jaffer)
 
+- #10539: Field kinds should be kept when copying types
+  Losing the sharing meant that one could desynchronize them between several
+  occurences of self, allowing a method to be both public and hidden,
+  which broke type soundness.
+  (Jacques Garrigue, review by Leo White)
+
 - #10542: Fix detection of immediate64 types through unboxed types.
   (Leo White, review by Stephen Dolan and Gabriel Scherer)
 

testsuite/tests/typing-objects/field_kind.ml

@@ -0,0 +1,73 @@
+(* TEST
+   * expect
+*)
+
+type _ t = Int : int t;;
+[%%expect{|
+type _ t = Int : int t
+|}]
+
+let o =
+  object (self)
+    method private x = 3
+    method m : type a. a t -> a = fun Int -> (self#x : int)
+  end;;
+[%%expect{|
+val o : < m : 'a. 'a t -> 'a > = <obj>
+|}]
+
+let o' =
+  object (self : 's)
+    method private x = 3
+    method m : type a. a t -> 's -> a = fun Int other -> (other#x : int)
+  end;;
+
+let aargh = assert (o'#m Int o' = 3);;
+[%%expect{|
+Lines 2-5, characters 2-5:
+2 | ..object (self : 's)
+3 |     method private x = 3
+4 |     method m : type a. a t -> 's -> a = fun Int other -> (other#x : int)
+5 |   end..
+Warning 15 [implicit-public-methods]: the following private methods were made public implicitly:
+ x.
+val o' : < m : 'a. 'a t -> 'b -> 'a; x : int > as 'b = <obj>
+val aargh : unit = ()
+|}]
+
+let o2 =
+  object (self : 's)
+    method private x = 3
+    method m : 's -> int = fun other -> (other#x : int)
+  end;;
+[%%expect{|
+Lines 2-5, characters 2-5:
+2 | ..object (self : 's)
+3 |     method private x = 3
+4 |     method m : 's -> int = fun other -> (other#x : int)
+5 |   end..
+Warning 15 [implicit-public-methods]: the following private methods were made public implicitly:
+ x.
+val o2 : < m : 'a -> int; x : int > as 'a = <obj>
+|}]
+
+let o3 =
+  object (self : 's)
+    method private x = 3
+    method m : 's -> int = fun other ->
+      let module M = struct let other = other end in (M.other#x : int)
+  end;;
+
+let aargh = assert (o3#m o3 = 3);;
+[%%expect{|
+Lines 2-6, characters 2-5:
+2 | ..object (self : 's)
+3 |     method private x = 3
+4 |     method m : 's -> int = fun other ->
+5 |       let module M = struct let other = other end in (M.other#x : int)
+6 |   end..
+Warning 15 [implicit-public-methods]: the following private methods were made public implicitly:
+ x.
+val o3 : < m : 'a -> int; x : int > as 'a = <obj>
+val aargh : unit = ()
+|}]

typing/btype.ml

@@ -494,42 +494,24 @@ module For_copy : sig
 
   val redirect_desc: copy_scope -> type_expr -> type_desc -> unit
 
-  val dup_kind: copy_scope -> field_kind option ref -> unit
-
   val with_scope: (copy_scope -> 'a) -> 'a
 end = struct
   type copy_scope = {
     mutable saved_desc : (transient_expr * type_desc) list;
     (* Save association of generic nodes with their description. *)
-
-    mutable saved_kinds: field_kind option ref list;
-    (* duplicated kind variables *)
-
-    mutable new_kinds  : field_kind option ref list;
-    (* new kind variables *)
   }
 
   let redirect_desc copy_scope ty desc =
     let ty = Transient_expr.repr ty in
     copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc;
     Transient_expr.set_desc ty desc
 
-  let dup_kind copy_scope r =
-    assert (Option.is_none !r);
-    if not (List.memq r copy_scope.new_kinds) then begin
-      copy_scope.saved_kinds <- r :: copy_scope.saved_kinds;
-      let r' = ref None in
-      copy_scope.new_kinds <- r' :: copy_scope.new_kinds;
-      r := Some (Fvar r')
-    end
-
   (* Restore type descriptions. *)
-  let cleanup { saved_desc; saved_kinds; _ } =
-    List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc;
-    List.iter (fun r -> r := None) saved_kinds
+  let cleanup { saved_desc; _ } =
+    List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc
 
   let with_scope f =
-    let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in
+    let scope = { saved_desc = [] } in
     let res = f scope in
     cleanup scope;
     res

typing/btype.mli

@@ -185,9 +185,6 @@ module For_copy : sig
   val redirect_desc: copy_scope -> type_expr -> type_desc -> unit
         (* Temporarily change a type description *)
 
-  val dup_kind: copy_scope -> field_kind option ref -> unit
-        (* Save a None field_kind, and make it point to a fresh Fvar *)
-
   val with_scope: (copy_scope -> 'a) -> 'a
         (* [with_scope f] calls [f] and restores saved type descriptions
            before returning its result. *)

typing/ctype.ml

@@ -1119,14 +1119,6 @@ let rec copy ?partial ?keep_names scope ty =
               (* Return a new copy *)
               Tvariant (copy_row copy true row keep more')
           end
-      | Tfield (_p, k, _ty1, ty2) ->
-          begin match field_kind_repr k with
-            Fabsent  -> Tlink (copy ty2)
-          | Fpresent -> copy_type_desc copy desc
-          | Fvar r ->
-              For_copy.dup_kind scope r;
-              copy_type_desc copy desc
-          end
       | Tobject (ty1, _) when partial <> None ->
           Tobject (copy ty1, ref None)
       | _ -> copy_type_desc ?keep_names copy desc