@@ -289,12 +289,43 @@ let repr = repr
289
289
290
290
(* *** Type maps ****)
291
291
292
- module TypePairs =
293
- Hashtbl. Make (struct
292
+ module TypePairs = struct
293
+ module H = Hashtbl. Make (struct
294
294
type t = type_expr * type_expr
295
295
let equal (t1 , t1' ) (t2 , t2' ) = (t1 == t2) && (t1' == t2')
296
296
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
298
329
299
330
300
331
(* *** unification mode ****)
@@ -305,7 +336,7 @@ type unification_mode =
305
336
306
337
type equations_generation =
307
338
| Forbidden
308
- | Allowed of { equated_types : unit TypePairs .t }
339
+ | Allowed of { equated_types : TypePairs .t }
309
340
310
341
let umode = ref Expression
311
342
let equations_generation = ref Forbidden
@@ -2269,9 +2300,8 @@ let rec mcomp type_pairs env t1 t2 =
2269
2300
(* Expansion may have changed the representative of the types... *)
2270
2301
let t1' = repr t1' and t2' = repr t2' in
2271
2302
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');
2275
2305
match (t1'.desc, t2'.desc) with
2276
2306
| (Tvar _, _)
2277
2307
| (_ , Tvar _ ) ->
@@ -2478,7 +2508,7 @@ let order_type_pair t1 t2 =
2478
2508
if t1.id < = t2.id then (t1, t2) else (t2, t1)
2479
2509
2480
2510
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)
2482
2512
2483
2513
let eq_package_path env p1 p2 =
2484
2514
Path. same p1 p2 ||
@@ -2572,8 +2602,7 @@ let unify_eq t1 t2 =
2572
2602
match ! umode with
2573
2603
| Expression -> false
2574
2604
| 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)
2577
2606
2578
2607
let unify1_var env t1 t2 =
2579
2608
assert (is_Tvar t1);
@@ -2592,7 +2621,7 @@ let unify1_var env t1 t2 =
2592
2621
let record_equation t1 t2 =
2593
2622
match ! equations_generation with
2594
2623
| Forbidden -> assert false
2595
- | Allowed { equated_types } -> TypePairs. add equated_types (t1, t2) ()
2624
+ | Allowed { equated_types } -> TypePairs. add equated_types (t1, t2)
2596
2625
2597
2626
let rec unify (env :Env.t ref ) t1 t2 =
2598
2627
(* First step: special cases (optimizations) *)
@@ -3320,10 +3349,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
3320
3349
(* Expansion may have changed the representative of the types... *)
3321
3350
let t1' = repr t1' and t2' = repr t2' in
3322
3351
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');
3327
3354
match (t1'.desc, t2'.desc) with
3328
3355
(Tvar _ , _ ) when may_instantiate inst_nongen t1' ->
3329
3356
moregen_occur env t1'.level t2;
@@ -3592,10 +3619,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
3592
3619
(* Expansion may have changed the representative of the types... *)
3593
3620
let t1' = repr t1' and t2' = repr t2' in
3594
3621
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');
3599
3624
match (t1'.desc, t2'.desc) with
3600
3625
(Tvar _ , Tvar _ ) when rename ->
3601
3626
begin try
@@ -3826,7 +3851,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
3826
3851
let sign2 = signature_of_class_type subj in
3827
3852
let t1 = repr sign1.csig_self in
3828
3853
let t2 = repr sign2.csig_self in
3829
- TypePairs. add type_pairs (t1, t2) () ;
3854
+ TypePairs. add type_pairs (t1, t2);
3830
3855
let (fields1, rest1) = flatten_fields (object_fields t1)
3831
3856
and (fields2, rest2) = flatten_fields (object_fields t2) in
3832
3857
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 =
3951
3976
let sign2 = signature_of_class_type subj_type in
3952
3977
let t1 = repr sign1.csig_self in
3953
3978
let t2 = repr sign2.csig_self in
3954
- TypePairs. add type_pairs (t1, t2) () ;
3979
+ TypePairs. add type_pairs (t1, t2);
3955
3980
let (fields1, rest1) = flatten_fields (object_fields t1)
3956
3981
and (fields2, rest2) = flatten_fields (object_fields t2) in
3957
3982
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
@@ -4283,11 +4308,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
4283
4308
let t2 = repr t2 in
4284
4309
if t1 == t2 then cstrs else
4285
4310
4286
- begin try
4287
- TypePairs. find subtypes (t1, t2);
4311
+ if TypePairs. mem subtypes (t1, t2) then
4288
4312
cstrs
4289
- with Not_found ->
4290
- TypePairs. add subtypes (t1, t2) () ;
4313
+ else begin
4314
+ TypePairs. add subtypes (t1, t2);
4291
4315
match (t1.desc, t2.desc) with
4292
4316
(Tvar _ , _ ) | (_ , Tvar _ ) ->
4293
4317
(trace, t1, t2, ! univar_pairs)::cstrs
0 commit comments