Merge pull request #4559 from BuckleScript/disable_hash_collision

disable hash collison test for polyvar

Author: bobzhang

jscomp/test/build.ninja

@@ -340,6 +340,7 @@ build test/gpr_return_type_unused_attribute.cmi test/gpr_return_type_unused_attr
 build test/gray_code_test.cmi test/gray_code_test.cmj : cc test/gray_code_test.ml | $stdlib
 build test/guide_for_ext.cmi test/guide_for_ext.cmj : cc test/guide_for_ext.ml | $stdlib
 build test/hamming_test.cmi test/hamming_test.cmj : cc test/hamming_test.ml | test/mt.cmj $stdlib
+build test/hash_collision.cmi test/hash_collision.cmj : cc test/hash_collision.ml | test/mt.cmj $stdlib
 build test/hash_test.cmi test/hash_test.cmj : cc test/hash_test.ml | test/mt.cmj test/mt_global.cmj $stdlib
 build test/hashtbl_test.cmi test/hashtbl_test.cmj : cc test/hashtbl_test.ml | test/mt.cmj $stdlib
 build test/hello.foo.cmi test/hello.foo.cmj : cc test/hello.foo.ml | $stdlib

jscomp/test/hash_collision.js

@@ -0,0 +1,60 @@
+'use strict';
+
+var Mt = require("./mt.js");
+
+var suites = {
+  contents: /* [] */0
+};
+
+var test_id = {
+  contents: 0
+};
+
+function eq(loc, x, y) {
+  return Mt.eq_suites(test_id, suites, loc, x, y);
+}
+
+function f0(x) {
+  if (x === "azdwbie") {
+    return 1;
+  } else {
+    return 0;
+  }
+}
+
+function f1(x) {
+  if (x.NAME === "azdwbie") {
+    return x.VAL + 2 | 0;
+  } else {
+    return x.VAL + 1 | 0;
+  }
+}
+
+var hi = [
+  "Eric_Cooper",
+  "azdwbie"
+];
+
+eq("File \"hash_collision.ml\", line 24, characters 9-16", 1, 0);
+
+eq("File \"hash_collision.ml\", line 25, characters 9-16", 1, 1);
+
+eq("File \"hash_collision.ml\", line 27, characters 9-16", f1({
+          NAME: "Eric_Cooper",
+          VAL: -1
+        }), 0);
+
+eq("File \"hash_collision.ml\", line 29, characters 9-16", f1({
+          NAME: "azdwbie",
+          VAL: -2
+        }), 0);
+
+Mt.from_pair_suites("hash_collision.ml", suites.contents);
+
+exports.suites = suites;
+exports.test_id = test_id;
+exports.eq = eq;
+exports.f0 = f0;
+exports.f1 = f1;
+exports.hi = hi;
+/*  Not a pure module */

jscomp/test/hash_collision.ml

@@ -0,0 +1,31 @@
+
+let suites :  Mt.pair_suites ref  = ref []
+let test_id = ref 0
+let eq loc x y = Mt.eq_suites ~test_id ~suites loc x y 
+
+type collision = [`Eric_Cooper | `azdwbie];;    
+
+let f0 x = 
+  match x with 
+  | `Eric_Cooper -> 0 
+  | `azdwbie -> 1 
+
+
+
+
+let f1 x = 
+  match x with 
+  | `Eric_Cooper x -> x + 1 
+  | `azdwbie x -> x + 2
+
+
+
+let hi : collision array = [| `Eric_Cooper; `azdwbie |]
+  ;;  eq __LOC__ (f0 `Eric_Cooper) 0 
+  ;;  eq __LOC__ (f0 `azdwbie) 1
+
+  ;;  eq __LOC__ (f1 (`Eric_Cooper (-1))) 0   
+  
+  ;;  eq __LOC__ (f1 (`azdwbie (-2))) 0   
+
+;; Mt.from_pair_suites __FILE__ !suites  

jscomp/test/poly_variant_test.ml

@@ -157,4 +157,8 @@ let hey x =
   | `h as v -> 
     Js.log "v";
     Js.log v  
+;;
+
+  
+  
 let () = Mt.from_pair_suites __MODULE__ !suites

lib/4.06.1/unstable/js_compiler.ml

@@ -40976,10 +40976,11 @@ let rec class_type_arity =
                   (*******************************************)
                   (*  Miscellaneous operations on row types  *)
                   (*******************************************)
+type row_fields = (Asttypes.label * Types.row_field) list
+type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list
+let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q)
 
-let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
-
-let rec merge_rf r1 r2 pairs fi1 fi2 =
+let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) =
   match fi1, fi2 with
     (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
       if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
@@ -40988,7 +40989,7 @@ let rec merge_rf r1 r2 pairs fi1 fi2 =
   | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
   | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
 
-let merge_row_fields fi1 fi2 =
+let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs =
   match fi1, fi2 with
     [], _ | _, [] -> (fi1, fi2, [])
   | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
@@ -43209,7 +43210,8 @@ and unify_row env row1 row2 =
   let rm1 = row_more row1 and rm2 = row_more row2 in
   if unify_eq rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
-  if r1 <> [] && r2 <> [] then begin
+  if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin
+    (* pairs are the intersection, r1 , r2 should be disjoint *)
     let ht = Hashtbl.create (List.length r1) in
     List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
     List.iter
@@ -57084,19 +57086,25 @@ and transl_type_aux env policy styp =
                          row_bound=(); row_closed=true;
                          row_fixed=false; row_name=None}) in
       let hfields = Hashtbl.create 17 in
+      let collection_detect = Hashtbl.create 17 in 
       let add_typed_field loc l f =
-        let h = Btype.hash_variant l in
+        if not !Config.bs_only  then begin 
+          let h = Btype.hash_variant l in
+          if Hashtbl.mem collection_detect h then 
+            let l' = Hashtbl.find collection_detect h  in 
+            (* Check for tag conflicts *)
+            if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          else Hashtbl.add collection_detect h l 
+        end ;
         try
-          let (l',f') = Hashtbl.find hfields h in
-          (* Check for tag conflicts *)
-          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let (_,f') = Hashtbl.find hfields l in
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
           with Unify _trace ->
             raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
-          Hashtbl.add hfields h (l,f)
+          Hashtbl.add hfields l (l,f)
       in
       let add_field = function
           Rtag (l, attrs, c, stl) ->
@@ -57127,13 +57135,10 @@ and transl_type_aux env policy styp =
                 {desc=Tconstr(p, tl, _)} -> Some(p, tl)
               | _                        -> None
             in
-            begin try
+            begin 
               (* Set name if there are no fields yet *)
-              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
-              name := nm
-            with Exit ->
-              (* Unset it otherwise *)
-              name := None
+              if Hashtbl.length hfields <> 0 then name := None
+              else name := nm
             end;
             let fl = match expand_head env cty.ctyp_type, nm with
               {desc=Tvariant row}, _ when Btype.static_row row ->

lib/4.06.1/unstable/js_refmt_compiler.ml

@@ -40976,10 +40976,11 @@ let rec class_type_arity =
                   (*******************************************)
                   (*  Miscellaneous operations on row types  *)
                   (*******************************************)
+type row_fields = (Asttypes.label * Types.row_field) list
+type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list
+let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q)
 
-let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
-
-let rec merge_rf r1 r2 pairs fi1 fi2 =
+let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) =
   match fi1, fi2 with
     (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
       if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
@@ -40988,7 +40989,7 @@ let rec merge_rf r1 r2 pairs fi1 fi2 =
   | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
   | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
 
-let merge_row_fields fi1 fi2 =
+let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs =
   match fi1, fi2 with
     [], _ | _, [] -> (fi1, fi2, [])
   | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
@@ -43209,7 +43210,8 @@ and unify_row env row1 row2 =
   let rm1 = row_more row1 and rm2 = row_more row2 in
   if unify_eq rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
-  if r1 <> [] && r2 <> [] then begin
+  if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin
+    (* pairs are the intersection, r1 , r2 should be disjoint *)
     let ht = Hashtbl.create (List.length r1) in
     List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
     List.iter
@@ -57084,19 +57086,25 @@ and transl_type_aux env policy styp =
                          row_bound=(); row_closed=true;
                          row_fixed=false; row_name=None}) in
       let hfields = Hashtbl.create 17 in
+      let collection_detect = Hashtbl.create 17 in 
       let add_typed_field loc l f =
-        let h = Btype.hash_variant l in
+        if not !Config.bs_only  then begin 
+          let h = Btype.hash_variant l in
+          if Hashtbl.mem collection_detect h then 
+            let l' = Hashtbl.find collection_detect h  in 
+            (* Check for tag conflicts *)
+            if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          else Hashtbl.add collection_detect h l 
+        end ;
         try
-          let (l',f') = Hashtbl.find hfields h in
-          (* Check for tag conflicts *)
-          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let (_,f') = Hashtbl.find hfields l in
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
           with Unify _trace ->
             raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
-          Hashtbl.add hfields h (l,f)
+          Hashtbl.add hfields l (l,f)
       in
       let add_field = function
           Rtag (l, attrs, c, stl) ->
@@ -57127,13 +57135,10 @@ and transl_type_aux env policy styp =
                 {desc=Tconstr(p, tl, _)} -> Some(p, tl)
               | _                        -> None
             in
-            begin try
+            begin 
               (* Set name if there are no fields yet *)
-              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
-              name := nm
-            with Exit ->
-              (* Unset it otherwise *)
-              name := None
+              if Hashtbl.length hfields <> 0 then name := None
+              else name := nm
             end;
             let fl = match expand_head env cty.ctyp_type, nm with
               {desc=Tvariant row}, _ when Btype.static_row row ->

lib/4.06.1/whole_compiler.ml

@@ -325881,10 +325881,11 @@ let rec class_type_arity =
                   (*******************************************)
                   (*  Miscellaneous operations on row types  *)
                   (*******************************************)
+type row_fields = (Asttypes.label * Types.row_field) list
+type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list
+let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q)
 
-let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
-
-let rec merge_rf r1 r2 pairs fi1 fi2 =
+let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) =
   match fi1, fi2 with
     (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
       if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
@@ -325893,7 +325894,7 @@ let rec merge_rf r1 r2 pairs fi1 fi2 =
   | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
   | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
 
-let merge_row_fields fi1 fi2 =
+let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs =
   match fi1, fi2 with
     [], _ | _, [] -> (fi1, fi2, [])
   | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
@@ -328114,7 +328115,8 @@ and unify_row env row1 row2 =
   let rm1 = row_more row1 and rm2 = row_more row2 in
   if unify_eq rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
-  if r1 <> [] && r2 <> [] then begin
+  if not true && (r1 <> [] && r2 <> []) then begin
+    (* pairs are the intersection, r1 , r2 should be disjoint *)
     let ht = Hashtbl.create (List.length r1) in
     List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
     List.iter
@@ -341304,19 +341306,25 @@ and transl_type_aux env policy styp =
                          row_bound=(); row_closed=true;
                          row_fixed=false; row_name=None}) in
       let hfields = Hashtbl.create 17 in
+      let collection_detect = Hashtbl.create 17 in 
       let add_typed_field loc l f =
-        let h = Btype.hash_variant l in
+        if not true  then begin 
+          let h = Btype.hash_variant l in
+          if Hashtbl.mem collection_detect h then 
+            let l' = Hashtbl.find collection_detect h  in 
+            (* Check for tag conflicts *)
+            if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          else Hashtbl.add collection_detect h l 
+        end ;
         try
-          let (l',f') = Hashtbl.find hfields h in
-          (* Check for tag conflicts *)
-          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let (_,f') = Hashtbl.find hfields l in
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
           with Unify _trace ->
             raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
-          Hashtbl.add hfields h (l,f)
+          Hashtbl.add hfields l (l,f)
       in
       let add_field = function
           Rtag (l, attrs, c, stl) ->
@@ -341347,13 +341355,10 @@ and transl_type_aux env policy styp =
                 {desc=Tconstr(p, tl, _)} -> Some(p, tl)
               | _                        -> None
             in
-            begin try
+            begin 
               (* Set name if there are no fields yet *)
-              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
-              name := nm
-            with Exit ->
-              (* Unset it otherwise *)
-              name := None
+              if Hashtbl.length hfields <> 0 then name := None
+              else name := nm
             end;
             let fl = match expand_head env cty.ctyp_type, nm with
               {desc=Tvariant row}, _ when Btype.static_row row ->