fix issue #8792 and replace log_type by set_type_desc in Btype (#9018)

Changes

@@ -296,6 +296,10 @@ Working version
   (Gabriel Scherer and Florian Angeletti,
    review by Florian Angeletti and Gabriel Radanne)
 
+- #8792, #9018: Possible (latent) bug in Ctype.normalize_type
+  removed incrimined Btype.log_type, replaced by Btype.set_type
+  (Jacques Garrigue, report by Alain Frisch, review by Thomas Refis)
+
 - #8855, #8858: Links for tools not created when installing with
   --disable-installing-byecode-programs (e.g. ocamldep.opt installed, but
   ocamldep link not created)

typing/btype.ml

@@ -737,6 +737,11 @@ let link_type ty ty' =
   | _ -> ()
   (* ; assert (check_memorized_abbrevs ()) *)
   (*  ; check_expans [] ty' *)
+let set_type_desc ty td =
+  if td != ty.desc then begin
+    log_type ty;
+    ty.desc <- td
+  end
 let set_level ty level =
   if level <> ty.level then begin
     if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));

typing/btype.mli

@@ -227,6 +227,8 @@ val undo_compress: snapshot -> unit
 val link_type: type_expr -> type_expr -> unit
         (* Set the desc field of [t1] to [Tlink t2], logging the old
            value if there is an active snapshot *)
+val set_type_desc: type_expr -> type_desc -> unit
+        (* Set directly the desc field, without sharing *)
 val set_level: type_expr -> int -> unit
 val set_scope: type_expr -> int -> unit
 val set_name:
@@ -238,8 +240,6 @@ val set_kind: field_kind option ref -> field_kind -> unit
 val set_commu: commutable ref -> commutable -> unit
 val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
         (* Set references, logging the old value *)
-val log_type: type_expr -> unit
-        (* Log the old value of a type, before modifying it by hand *)
 
 (**** Forward declarations ****)
 val print_raw: (Format.formatter -> type_expr -> unit) ref

typing/ctype.ml

@@ -848,7 +848,7 @@ let rec update_level env level expand ty =
     | Tpackage (p, nl, tl) when level < Path.scope p ->
         let p' = normalize_package_path env p in
         if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]);
-        log_type ty; ty.desc <- Tpackage (p', nl, tl);
+        set_type_desc ty (Tpackage (p', nl, tl));
         update_level env level expand ty
     | Tobject(_, ({contents=Some(p, _tl)} as nm))
       when level < Path.scope p ->
@@ -858,8 +858,7 @@ let rec update_level env level expand ty =
         let row = row_repr row in
         begin match row.row_name with
         | Some (p, _tl) when level < Path.scope p ->
-            log_type ty;
-            ty.desc <- Tvariant {row with row_name = None}
+            set_type_desc ty (Tvariant {row with row_name = None})
         | _ -> ()
         end;
         set_level ty level;
@@ -2751,7 +2750,7 @@ and unify_list env tl1 tl2 =
 and make_rowvar level use1 rest1 use2 rest2  =
   let set_name ty name =
     match ty.desc with
-      Tvar None -> log_type ty; ty.desc <- Tvar name
+      Tvar None -> set_type_desc ty (Tvar name)
     | _ -> ()
   in
   let name =
@@ -2791,8 +2790,8 @@ and unify_fields env ty1 ty2 =          (* Optimization *)
       )
       pairs
   with exn ->
-    log_type rest1; rest1.desc <- d1;
-    log_type rest2; rest2.desc <- d2;
+    set_type_desc rest1 d1;
+    set_type_desc rest2 d2;
     raise exn
 
 and unify_kind k1 k2 =
@@ -2902,7 +2901,7 @@ and unify_row env row1 row2 =
       if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
     end
   with exn ->
-    log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+    set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
   end
 
 and unify_row_field env fixed1 fixed2 more l f1 f2 =
@@ -4444,8 +4443,7 @@ let rec normalize_type_rec env visited ty =
       match tm.desc with (* PR#7348 *)
         Tconstr (Path.Pdot(m,i), tl, _abbrev) ->
           let i' = String.sub i 0 (String.length i - 4) in
-          log_type ty;
-          ty.desc <- Tconstr(Path.Pdot(m,i'), tl, ref Mnil)
+          set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil))
       | _ -> assert false
     else match ty.desc with
     | Tvariant row ->
@@ -4469,8 +4467,7 @@ let rec normalize_type_rec env visited ty =
       let fields =
         List.sort (fun (p,_) (q,_) -> compare p q)
           (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
-      log_type ty;
-      ty.desc <- Tvariant {row with row_fields = fields}
+      set_type_desc ty (Tvariant {row with row_fields = fields})
     | Tobject (fi, nm) ->
         begin match !nm with
         | None -> ()
@@ -4483,7 +4480,7 @@ let rec normalize_type_rec env visited ty =
             | Tvar _ | Tunivar _ ->
                 if v' != v then set_name nm (Some (n, v' :: l))
             | Tnil ->
-                log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
+                set_type_desc ty (Tconstr (n, l, ref Mnil))
             | _ -> set_name nm None
             end
         | _ ->
@@ -4493,7 +4490,7 @@ let rec normalize_type_rec env visited ty =
         if fi.level < lowest_level then () else
         let fields, row = flatten_fields fi in
         let fi' = build_fields fi.level fields row in
-        log_type ty; fi.desc <- fi'.desc
+        set_type_desc fi fi'.desc
     | _ -> ()
     end;
     iter_type_expr (normalize_type_rec env visited) ty

typing/typecore.ml

@@ -1885,7 +1885,7 @@ let check_univars env expans kind exp ty_expected vars =
         generalize t;
         match t.desc with
           Tvar name when t.level = generic_level ->
-            log_type t; t.desc <- Tunivar name; true
+            set_type_desc t (Tunivar name); true
         | _ -> false)
       vars in
   if List.length vars = List.length vars' then () else

typing/typetexp.ml

@@ -361,8 +361,8 @@ and transl_type_aux env policy styp =
           let t = instance t in
           let px = Btype.proxy t in
           begin match px.desc with
-          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
-          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
+          | Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
+          | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
           | _ -> ()
           end;
           { ty with ctyp_type = t }