right way to duplicate field kinds

git-svn-id: http://caml.inria.fr/svn/ocaml/version/3.09@7248 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/btype.ml

@@ -252,10 +252,9 @@ let rec copy_type_desc f = function
   | Tobject(ty, {contents = Some (p, tl)})
                         -> Tobject (f ty, ref (Some(p, List.map f tl)))
   | Tobject (ty, _)     -> Tobject (f ty, ref None)
-  | Tvariant row        ->
-      let row = row_repr row in
-      Tvariant (copy_row f true row false (f row.row_more))
-  | Tfield (p, k, ty1, ty2) -> Tfield (p, copy_kind k, f ty1, f ty2)
+  | Tvariant row        -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
   | Tsubst ty           -> assert false
@@ -273,10 +272,22 @@ let saved_desc = ref []
 let save_desc ty desc = 
   saved_desc := (ty, desc)::!saved_desc
 
+let saved_kinds = ref [] (* duplicated kind variables *)
+let new_kinds = ref []   (* new kind variables *)
+let dup_kind r =
+  (match !r with None -> () | Some _ -> assert false);
+  if not (List.memq r !new_kinds) then begin
+    saved_kinds := r :: !saved_kinds;
+    let r' = ref None in
+    new_kinds := r' :: !new_kinds;
+    r := Some (Fvar r')
+  end
+
 (* Restored type descriptions. *)
 let cleanup_types () =
   List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
-  saved_desc := []
+  List.iter (fun r -> r := None) !saved_kinds;
+  saved_desc := []; saved_kinds := []; new_kinds := []
 
 (* Mark a type. *)
 let rec mark_type ty =

typing/btype.mli

@@ -81,6 +81,8 @@ val copy_kind: field_kind -> field_kind
 
 val save_desc: type_expr -> type_desc -> unit
         (* Save a type description *)
+val dup_kind: field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
 val cleanup_types: unit -> unit
         (* Restore type descriptions *)
 

typing/ctype.ml

@@ -280,29 +280,19 @@ let remove_object_name ty =
 
 (**** Hiding of private methods ****)
 
-let rec hide_private_methods rv ty =
-  let ty = repr ty in
-  if ty.level >= lowest_level then begin
-    mark_type_node ty;
-    begin match ty.desc with
-      Tobject (fi, nm) when object_row fi == rv ->
-        nm := None;
-        let (fl, _) = flatten_fields fi in
-        List.iter
-          (fun (_, k, _) ->
-            match field_kind_repr k with
-              Fvar r -> set_kind r Fabsent
-            | _      -> ())
-          fl
-    | _ -> ()
-    end;
-    iter_type_expr (hide_private_methods rv) ty
-  end
-
 let hide_private_methods ty =
-  hide_private_methods (object_row ty) ty;
-  unmark_type ty
-
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
 
 
                               (*******************************)
@@ -801,20 +791,28 @@ let rec copy ty =
               let keep = more.level <> generic_level in
               let more' =
                 match more.desc with
-                  Tsubst ty -> ty
-                | Tconstr _ ->
-                    if keep then save_desc more more.desc;
-                    copy more
+		  Tsubst ty -> ty
+		| Tconstr _ ->
+		    if keep then save_desc more more.desc;
+		    copy more
                 | Tvar | Tunivar ->
                     save_desc more more.desc;
                     if keep then more else newty more.desc
-                |  _ -> assert false
+		|  _ -> assert false
               in
               (* Register new type first for recursion *)
               more.desc <- Tsubst(newgenty(Ttuple[more';t]));
               (* 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 ->
+              dup_kind r;
+              copy_type_desc copy desc
+          end
       | _ -> copy_type_desc copy desc
       end;
     t

typing/subst.ml

@@ -132,16 +132,8 @@ let rec typexp s ty =
               | None ->
                   Tvariant row
           end
-      | Tfield(label, kind, t1, t2) ->
-          begin match field_kind_repr kind with
-            Fpresent ->
-              Tfield(label, Fpresent, typexp s t1, typexp s t2)
-          | Fabsent ->
-              Tlink (typexp s t2)
-          | Fvar _ (* {contents = None} *) as k ->
-              let k = if s.for_saving then Fvar(ref None) else k in
-              Tfield(label, k, typexp s t1, typexp s t2)
-          end
+      | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp s t2)
       | _ -> copy_type_desc (typexp s) desc
       end;
     ty'