Skip to content

Commit 2af3f55

Browse files
stedolanlpw25
authored andcommitted
Fix a flaky test by refactoring TypePairs (ocaml/ocaml#10638)
1 parent 58dd807 commit 2af3f55

File tree

4 files changed

+60
-29
lines changed

4 files changed

+60
-29
lines changed

testsuite/tests/typing-gadts/principality-and-gadts.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -362,7 +362,7 @@ val foo : int foo -> int = <fun>
362362
Line 3, characters 26-31:
363363
3 | | { x = (x : int); eq = Refl3 } -> x
364364
^^^^^
365-
Warning 18 [not-principal]: typing this pattern requires considering M.t and int as equal.
365+
Warning 18 [not-principal]: typing this pattern requires considering M.t and N.t as equal.
366366
But the knowledge of these types is not principal.
367367
val foo : int foo -> int = <fun>
368368
|}]

typing/ctype.ml

Lines changed: 49 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -289,12 +289,43 @@ let repr = repr
289289

290290
(**** Type maps ****)
291291

292-
module TypePairs =
293-
Hashtbl.Make (struct
292+
module TypePairs = struct
293+
module H = Hashtbl.Make (struct
294294
type t = type_expr * type_expr
295295
let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
296296
let hash (t, t') = t.id + 93 * t'.id
297-
end)
297+
end)
298+
299+
type t = {
300+
set : unit H.t;
301+
mutable elems : (type_expr * type_expr) list;
302+
(* elems preserves the (reversed) insertion order of elements *)
303+
}
304+
305+
let create n =
306+
{ elems = []; set = H.create n }
307+
308+
let clear t =
309+
t.elems <- [];
310+
H.clear t.set
311+
312+
let repr2 (t1, t2) = (repr t1, repr t2)
313+
314+
let add t p =
315+
let p = repr2 p in
316+
if H.mem t.set p then () else begin
317+
H.add t.set p ();
318+
t.elems <- p :: t.elems
319+
end
320+
321+
let mem t p = H.mem t.set (repr2 p)
322+
323+
let iter f t =
324+
(* iterate in insertion order, not Hashtbl.iter order *)
325+
List.rev t.elems
326+
|> List.iter (fun (t1,t2) ->
327+
f (t1, t2))
328+
end
298329

299330

300331
(**** unification mode ****)
@@ -305,7 +336,7 @@ type unification_mode =
305336

306337
type equations_generation =
307338
| Forbidden
308-
| Allowed of { equated_types : unit TypePairs.t }
339+
| Allowed of { equated_types : TypePairs.t }
309340

310341
let umode = ref Expression
311342
let equations_generation = ref Forbidden
@@ -2269,9 +2300,8 @@ let rec mcomp type_pairs env t1 t2 =
22692300
(* Expansion may have changed the representative of the types... *)
22702301
let t1' = repr t1' and t2' = repr t2' in
22712302
if t1' == t2' then () else
2272-
begin try TypePairs.find type_pairs (t1', t2')
2273-
with Not_found ->
2274-
TypePairs.add type_pairs (t1', t2') ();
2303+
if not (TypePairs.mem type_pairs (t1', t2')) then begin
2304+
TypePairs.add type_pairs (t1', t2');
22752305
match (t1'.desc, t2'.desc) with
22762306
| (Tvar _, _)
22772307
| (_, Tvar _) ->
@@ -2478,7 +2508,7 @@ let order_type_pair t1 t2 =
24782508
if t1.id <= t2.id then (t1, t2) else (t2, t1)
24792509

24802510
let add_type_equality t1 t2 =
2481-
TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
2511+
TypePairs.add unify_eq_set (order_type_pair t1 t2)
24822512

24832513
let eq_package_path env p1 p2 =
24842514
Path.same p1 p2 ||
@@ -2572,8 +2602,7 @@ let unify_eq t1 t2 =
25722602
match !umode with
25732603
| Expression -> false
25742604
| Pattern ->
2575-
try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
2576-
with Not_found -> false
2605+
TypePairs.mem unify_eq_set (order_type_pair t1 t2)
25772606

25782607
let unify1_var env t1 t2 =
25792608
assert (is_Tvar t1);
@@ -2592,7 +2621,7 @@ let unify1_var env t1 t2 =
25922621
let record_equation t1 t2 =
25932622
match !equations_generation with
25942623
| Forbidden -> assert false
2595-
| Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) ()
2624+
| Allowed { equated_types } -> TypePairs.add equated_types (t1, t2)
25962625

25972626
let rec unify (env:Env.t ref) t1 t2 =
25982627
(* First step: special cases (optimizations) *)
@@ -3320,10 +3349,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
33203349
(* Expansion may have changed the representative of the types... *)
33213350
let t1' = repr t1' and t2' = repr t2' in
33223351
if t1' == t2' then () else
3323-
begin try
3324-
TypePairs.find type_pairs (t1', t2')
3325-
with Not_found ->
3326-
TypePairs.add type_pairs (t1', t2') ();
3352+
if not (TypePairs.mem type_pairs (t1', t2')) then begin
3353+
TypePairs.add type_pairs (t1', t2');
33273354
match (t1'.desc, t2'.desc) with
33283355
(Tvar _, _) when may_instantiate inst_nongen t1' ->
33293356
moregen_occur env t1'.level t2;
@@ -3592,10 +3619,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
35923619
(* Expansion may have changed the representative of the types... *)
35933620
let t1' = repr t1' and t2' = repr t2' in
35943621
if t1' == t2' then () else
3595-
begin try
3596-
TypePairs.find type_pairs (t1', t2')
3597-
with Not_found ->
3598-
TypePairs.add type_pairs (t1', t2') ();
3622+
if not (TypePairs.mem type_pairs (t1', t2')) then begin
3623+
TypePairs.add type_pairs (t1', t2');
35993624
match (t1'.desc, t2'.desc) with
36003625
(Tvar _, Tvar _) when rename ->
36013626
begin try
@@ -3826,7 +3851,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
38263851
let sign2 = signature_of_class_type subj in
38273852
let t1 = repr sign1.csig_self in
38283853
let t2 = repr sign2.csig_self in
3829-
TypePairs.add type_pairs (t1, t2) ();
3854+
TypePairs.add type_pairs (t1, t2);
38303855
let (fields1, rest1) = flatten_fields (object_fields t1)
38313856
and (fields2, rest2) = flatten_fields (object_fields t2) in
38323857
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
@@ -3951,7 +3976,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
39513976
let sign2 = signature_of_class_type subj_type in
39523977
let t1 = repr sign1.csig_self in
39533978
let t2 = repr sign2.csig_self in
3954-
TypePairs.add type_pairs (t1, t2) ();
3979+
TypePairs.add type_pairs (t1, t2);
39553980
let (fields1, rest1) = flatten_fields (object_fields t1)
39563981
and (fields2, rest2) = flatten_fields (object_fields t2) in
39573982
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
@@ -4283,11 +4308,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
42834308
let t2 = repr t2 in
42844309
if t1 == t2 then cstrs else
42854310

4286-
begin try
4287-
TypePairs.find subtypes (t1, t2);
4311+
if TypePairs.mem subtypes (t1, t2) then
42884312
cstrs
4289-
with Not_found ->
4290-
TypePairs.add subtypes (t1, t2) ();
4313+
else begin
4314+
TypePairs.add subtypes (t1, t2);
42914315
match (t1.desc, t2.desc) with
42924316
(Tvar _, _) | (_, Tvar _) ->
42934317
(trace, t1, t2, !univar_pairs)::cstrs

typing/ctype.mli

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,14 @@
1818
open Asttypes
1919
open Types
2020

21-
module TypePairs : Hashtbl.S with type key = type_expr * type_expr
21+
module TypePairs : sig
22+
type t
23+
val create: int -> t
24+
val clear: t -> unit
25+
val add: t -> type_expr * type_expr -> unit
26+
val mem: t -> type_expr * type_expr -> bool
27+
val iter: (type_expr * type_expr -> unit) -> t -> unit
28+
end
2229

2330
module Unification_trace: sig
2431
(** Unification traces are used to explain unification errors
@@ -257,7 +264,7 @@ val unify: Env.t -> type_expr -> type_expr -> unit
257264
(* Unify the two types given. Raise [Unify] if not possible. *)
258265
val unify_gadt:
259266
equations_level:int -> allow_recursive:bool ->
260-
Env.t ref -> type_expr -> type_expr -> unit TypePairs.t
267+
Env.t ref -> type_expr -> type_expr -> TypePairs.t
261268
(* Unify the two types given and update the environment with the
262269
local constraints. Raise [Unify] if not possible.
263270
Returns the pairs of types that have been equated. *)

typing/typecore.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1820,7 +1820,7 @@ and type_pat_aux
18201820
if !Clflags.principal then (
18211821
let exception Warn_only_once in
18221822
try
1823-
TypePairs.iter (fun (t1, t2) () ->
1823+
TypePairs.iter (fun (t1, t2) ->
18241824
generalize_structure t1;
18251825
generalize_structure t2;
18261826
if not (fully_generic t1 && fully_generic t2) then

0 commit comments

Comments
 (0)