Skip to content

Commit e476e76

Browse files
bobzhangbobzhang
committed
Merge pull request #409 from bloomberg/fix_ocamlgraph
[fix] fix issue #405
2 parents d678f4a + 9cb7957 commit e476e76

File tree

6 files changed

+255
-6
lines changed

6 files changed

+255
-6
lines changed

‎jscomp/lam_beta_reduce.ml‎

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -94,11 +94,9 @@ let rewrite (map : (Ident.t, _) Hashtbl.t)
9494
let l2 = aux l2 in
9595
Llet(str, v, l1, l2 )
9696
| Lletrec(bindings, body) ->
97-
let bindings =
98-
bindings |> List.map (fun (k,l) ->
99-
let k = rebind k in
100-
(k, aux l)
101-
) in
97+
(*order matters see GPR #405*)
98+
let vars = List.map (fun (k, _) -> rebind k) bindings in
99+
let bindings = List.map2 (fun var (_,l) -> var, aux l) vars bindings in
102100
let body = aux body in
103101
Lletrec(bindings, body)
104102
| Lfunction(kind, params, body) ->

‎jscomp/test/.depend‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ demo_int_map.cmi :
88
ext_pervasives.cmi : ../stdlib/int32.cmi ../stdlib/format.cmi
99
ext_sys.cmi :
1010
float_record.cmi :
11+
gpr_405_test.cmi :
1112
inline_edge_cases.cmi :
1213
inline_map_test.cmi :
1314
map_test.cmi :
@@ -210,6 +211,8 @@ global_exception_regression_test.cmj : mt.cmi
210211
global_exception_regression_test.cmx : mt.cmx
211212
google_closure_test.cmj : test_google_closure.cmj mt.cmi
212213
google_closure_test.cmx : test_google_closure.cmx mt.cmx
214+
gpr_405_test.cmj : ../stdlib/hashtbl.cmi gpr_405_test.cmi
215+
gpr_405_test.cmx : ../stdlib/hashtbl.cmx gpr_405_test.cmi
213216
guide_for_ext.cmj :
214217
guide_for_ext.cmx :
215218
hamming_test.cmj : ../stdlib/printf.cmi mt.cmi ../stdlib/lazy.cmi \
@@ -858,6 +861,8 @@ global_exception_regression_test.cmo : mt.cmi
858861
global_exception_regression_test.cmj : mt.cmj
859862
google_closure_test.cmo : test_google_closure.cmo mt.cmi
860863
google_closure_test.cmj : test_google_closure.cmj mt.cmj
864+
gpr_405_test.cmo : ../stdlib/hashtbl.cmi gpr_405_test.cmi
865+
gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi
861866
guide_for_ext.cmo :
862867
guide_for_ext.cmj :
863868
hamming_test.cmo : ../stdlib/printf.cmi mt.cmi ../stdlib/lazy.cmi \

‎jscomp/test/gpr_405_test.ml‎

Lines changed: 95 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,95 @@
1+
2+
module type G = sig
3+
type t
4+
module V : sig
5+
6+
(** Vertices are {!COMPARABLE}. *)
7+
8+
type t
9+
10+
val compare : t -> t -> int
11+
val hash : t -> int
12+
val equal : t -> t -> bool
13+
14+
type label
15+
val create : label -> t
16+
val label : t -> label
17+
18+
end
19+
val succ : t -> V.t -> V.t list
20+
end
21+
22+
module Make (G : G) = struct
23+
24+
module H = Hashtbl.Make (G.V)
25+
26+
let find_default htbl x =
27+
try H.find htbl x
28+
with Not_found -> false
29+
30+
let min_cutset gr first_node =
31+
let n_labels = H.create 97 in
32+
let l_labels = H.create 97 in
33+
34+
let already_processed = H.create 97 in
35+
let is_already_processed x = find_default already_processed x in
36+
37+
let on_the_stack = H.create 97 in
38+
let is_on_the_stack x = find_default on_the_stack x in
39+
let cut_set = ref [] in
40+
let counter = ref 1 in
41+
42+
let rec step2 top rest_of_stack =
43+
assert (not (is_already_processed top));
44+
assert (not (is_on_the_stack top));
45+
H.add on_the_stack top true;
46+
H.add n_labels top !counter;
47+
counter := !counter + 1;
48+
H.add l_labels top 0;
49+
H.add already_processed top true;
50+
step3 (G.succ gr top) top rest_of_stack
51+
52+
and step3 successors top rest_of_stack = match successors with
53+
| successor :: other_successors ->
54+
if not (is_already_processed successor)
55+
(* step 4 *)
56+
then step2 successor ((top,successors)::rest_of_stack)
57+
(* step 5 *)
58+
else begin
59+
let x =
60+
if is_on_the_stack successor
61+
then H.find n_labels successor
62+
else H.find l_labels successor
63+
in
64+
H.add l_labels top
65+
(max (H.find l_labels top) x) ;
66+
step3 other_successors top rest_of_stack
67+
end
68+
69+
| [] -> begin
70+
(* step 7 *)
71+
if H.find l_labels top = H.find n_labels top
72+
then begin
73+
cut_set := top::!cut_set ;
74+
H.add l_labels top 0 ;
75+
end ;
76+
77+
(* check added between algorithms C and D *)
78+
if H.find l_labels top > H.find n_labels top
79+
then raise (Invalid_argument "Graph.Mincut: graph not reducible")
80+
81+
(* step 8 *)
82+
else match rest_of_stack with
83+
| [] -> !cut_set (* SUCCESS *)
84+
| (new_top, new_successors)::new_tail -> begin
85+
H.add on_the_stack top false;
86+
H.add l_labels new_top
87+
(max (H.find l_labels top) (H.find l_labels new_top)) ;
88+
step3 new_successors new_top new_tail
89+
end
90+
end in
91+
92+
(* step 2 *)
93+
step2 first_node []
94+
95+
end

‎jscomp/test/gpr_405_test.mli‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
2+
module type G = sig
3+
type t
4+
module V : sig
5+
6+
(** Vertices are {!COMPARABLE}. *)
7+
8+
type t
9+
10+
val compare : t -> t -> int
11+
val hash : t -> int
12+
val equal : t -> t -> bool
13+
14+
type label
15+
val create : label -> t
16+
val label : t -> label
17+
18+
end
19+
val succ : t -> V.t -> V.t list
20+
end
21+
22+
module Make (G : G) : sig
23+
24+
val min_cutset : G.t -> G.V.t -> G.V.t list
25+
26+
end

‎jscomp/test/test.mllib‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -305,4 +305,5 @@ ignore_test
305305
test_index
306306

307307
obj_literal_ppx_test
308-
obj_literal_ppx
308+
obj_literal_ppx
309+
gpr_405_test

‎lib/js/test/gpr_405_test.js‎

Lines changed: 124 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,124 @@
1+
// GENERATED CODE BY BUCKLESCRIPT VERSION 0.5.0 , PLEASE EDIT WITH CARE
2+
'use strict';
3+
4+
var Caml_builtin_exceptions = require("../caml_builtin_exceptions");
5+
var Hashtbl = require("../hashtbl");
6+
var Pervasives = require("../pervasives");
7+
var Curry = require("../curry");
8+
9+
function Make(funarg) {
10+
var $$let = funarg[/* V */0];
11+
var H = Hashtbl.Make([
12+
$$let[2],
13+
$$let[1]
14+
]);
15+
var find_default = function (htbl, x) {
16+
try {
17+
return Curry._2(H[/* find */6], htbl, x);
18+
}
19+
catch (exn){
20+
if (exn === Caml_builtin_exceptions.not_found) {
21+
return /* false */0;
22+
}
23+
else {
24+
throw exn;
25+
}
26+
}
27+
};
28+
var min_cutset = function (gr, first_node) {
29+
var n_labels = Curry._1(H[/* create */0], 97);
30+
var l_labels = Curry._1(H[/* create */0], 97);
31+
var already_processed = Curry._1(H[/* create */0], 97);
32+
var on_the_stack = Curry._1(H[/* create */0], 97);
33+
var cut_set = [/* [] */0];
34+
var counter = [1];
35+
var step2 = function (top, rest_of_stack) {
36+
if (find_default(already_processed, top)) {
37+
throw [
38+
Caml_builtin_exceptions.assert_failure,
39+
[
40+
"gpr_405_test.ml",
41+
43,
42+
6
43+
]
44+
];
45+
}
46+
if (find_default(on_the_stack, top)) {
47+
throw [
48+
Caml_builtin_exceptions.assert_failure,
49+
[
50+
"gpr_405_test.ml",
51+
44,
52+
6
53+
]
54+
];
55+
}
56+
Curry._3(H[/* add */4], on_the_stack, top, /* true */1);
57+
Curry._3(H[/* add */4], n_labels, top, counter[0]);
58+
counter[0] = counter[0] + 1 | 0;
59+
Curry._3(H[/* add */4], l_labels, top, 0);
60+
Curry._3(H[/* add */4], already_processed, top, /* true */1);
61+
var _successors = Curry._2(funarg[/* succ */1], gr, top);
62+
var _top = top;
63+
var _rest_of_stack = rest_of_stack;
64+
while(true) {
65+
var rest_of_stack$1 = _rest_of_stack;
66+
var top$1 = _top;
67+
var successors = _successors;
68+
if (successors) {
69+
var successor = successors[0];
70+
if (find_default(already_processed, successor)) {
71+
var x = find_default(on_the_stack, successor) ? Curry._2(H[/* find */6], n_labels, successor) : Curry._2(H[/* find */6], l_labels, successor);
72+
Curry._3(H[/* add */4], l_labels, top$1, Pervasives.max(Curry._2(H[/* find */6], l_labels, top$1), x));
73+
_successors = successors[1];
74+
continue ;
75+
76+
}
77+
else {
78+
return step2(successor, /* :: */[
79+
/* tuple */[
80+
top$1,
81+
successors
82+
],
83+
rest_of_stack$1
84+
]);
85+
}
86+
}
87+
else {
88+
if (Curry._2(H[/* find */6], l_labels, top$1) === Curry._2(H[/* find */6], n_labels, top$1)) {
89+
cut_set[0] = /* :: */[
90+
top$1,
91+
cut_set[0]
92+
];
93+
Curry._3(H[/* add */4], l_labels, top$1, 0);
94+
}
95+
if (Curry._2(H[/* find */6], l_labels, top$1) > Curry._2(H[/* find */6], n_labels, top$1)) {
96+
throw [
97+
Caml_builtin_exceptions.invalid_argument,
98+
"Graph.Mincut: graph not reducible"
99+
];
100+
}
101+
else if (rest_of_stack$1) {
102+
var match = rest_of_stack$1[0];
103+
var new_top = match[0];
104+
Curry._3(H[/* add */4], on_the_stack, top$1, /* false */0);
105+
Curry._3(H[/* add */4], l_labels, new_top, Pervasives.max(Curry._2(H[/* find */6], l_labels, top$1), Curry._2(H[/* find */6], l_labels, new_top)));
106+
_rest_of_stack = rest_of_stack$1[1];
107+
_top = new_top;
108+
_successors = match[1];
109+
continue ;
110+
111+
}
112+
else {
113+
return cut_set[0];
114+
}
115+
}
116+
};
117+
};
118+
return step2(first_node, /* [] */0);
119+
};
120+
return [min_cutset];
121+
}
122+
123+
exports.Make = Make;
124+
/* Hashtbl Not a pure module */

0 commit comments

Comments
 (0)