From faa64b30537855022cd62883ac945404fe4d0ffc Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Fri, 13 Jan 2012 17:46:21 +0000 Subject: Fix bug #5476: native code compilation of let rec on float arrays Applied the two patches of Gabriel Scherer to (1) fix the bug with float array in let-rec, and (2) add a test-suite for let-rec git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12021 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- testsuite/tests/letrec/Makefile | 4 ++++ testsuite/tests/letrec/backreferences.ml | 18 ++++++++++++++++++ testsuite/tests/letrec/class_1.ml | 5 +++++ testsuite/tests/letrec/class_2.ml | 8 ++++++++ testsuite/tests/letrec/class_2.reference | 2 ++ testsuite/tests/letrec/evaluation_order_1.ml | 20 ++++++++++++++++++++ testsuite/tests/letrec/evaluation_order_1.reference | 3 +++ testsuite/tests/letrec/evaluation_order_2.ml | 18 ++++++++++++++++++ testsuite/tests/letrec/evaluation_order_2.reference | 3 +++ testsuite/tests/letrec/evaluation_order_3.ml | 11 +++++++++++ testsuite/tests/letrec/evaluation_order_3.reference | 6 ++++++ testsuite/tests/letrec/float_block_1.ml | 10 ++++++++++ testsuite/tests/letrec/float_block_1.reference | 2 ++ testsuite/tests/letrec/float_block_2.ml | 7 +++++++ testsuite/tests/letrec/lists.ml | 8 ++++++++ testsuite/tests/letrec/mixing_value_closures_1.ml | 8 ++++++++ testsuite/tests/letrec/mixing_value_closures_2.ml | 8 ++++++++ testsuite/tests/letrec/mutual_functions.ml | 11 +++++++++++ 18 files changed, 152 insertions(+) create mode 100644 testsuite/tests/letrec/Makefile create mode 100644 testsuite/tests/letrec/backreferences.ml create mode 100644 testsuite/tests/letrec/class_1.ml create mode 100644 testsuite/tests/letrec/class_2.ml create mode 100644 testsuite/tests/letrec/class_2.reference create mode 100644 testsuite/tests/letrec/evaluation_order_1.ml create mode 100644 testsuite/tests/letrec/evaluation_order_1.reference create mode 100644 testsuite/tests/letrec/evaluation_order_2.ml create mode 100644 testsuite/tests/letrec/evaluation_order_2.reference create mode 100644 testsuite/tests/letrec/evaluation_order_3.ml create mode 100644 testsuite/tests/letrec/evaluation_order_3.reference create mode 100644 testsuite/tests/letrec/float_block_1.ml create mode 100644 testsuite/tests/letrec/float_block_1.reference create mode 100644 testsuite/tests/letrec/float_block_2.ml create mode 100644 testsuite/tests/letrec/lists.ml create mode 100644 testsuite/tests/letrec/mixing_value_closures_1.ml create mode 100644 testsuite/tests/letrec/mixing_value_closures_2.ml create mode 100644 testsuite/tests/letrec/mutual_functions.ml (limited to 'testsuite/tests/letrec') diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile new file mode 100644 index 0000000000..bcc2fdb011 --- /dev/null +++ b/testsuite/tests/letrec/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml new file mode 100644 index 0000000000..4a893225b1 --- /dev/null +++ b/testsuite/tests/letrec/backreferences.ml @@ -0,0 +1,18 @@ +(* testing backreferences; some compilation scheme may handle + differently recursive references to a mutually-recursive RHS + depending on whether it is before or after in the bindings list *) +type t = { x : t; y : t; z : t } + +let test = + let rec x = { x; y; z } + and y = { x; y; z } + and z = { x; y; z } + in + List.iter (fun (f, t_ref) -> + List.iter (fun t -> assert (f t == t_ref)) [x; y; z] + ) + [ + (fun t -> t.x), x; + (fun t -> t.y), y; + (fun t -> t.z), z; + ] diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml new file mode 100644 index 0000000000..a7d0338802 --- /dev/null +++ b/testsuite/tests/letrec/class_1.ml @@ -0,0 +1,5 @@ +(* class expression are compiled to recursive bindings *) +class test = +object + method x = 1 +end diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml new file mode 100644 index 0000000000..71c7880d67 --- /dev/null +++ b/testsuite/tests/letrec/class_2.ml @@ -0,0 +1,8 @@ +(* class expressions may also contain local recursive bindings *) +class test = + let rec f = print_endline "f"; fun x -> g x + and g = print_endline "g"; fun x -> f x in +object + method f : 'a 'b. 'a -> 'b = f + method g : 'a 'b. 'a -> 'b = g +end diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference new file mode 100644 index 0000000000..ab713757f4 --- /dev/null +++ b/testsuite/tests/letrec/class_2.reference @@ -0,0 +1,2 @@ +f +g diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml new file mode 100644 index 0000000000..5b88844d7e --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_1.ml @@ -0,0 +1,20 @@ +(* test evaluation order + + 'y' is translated into a constant, and is therefore considered + non-recursive. With the current letrec compilation method, + it should be evaluated before x and z. +*) +type tree = Tree of tree list + +let test = + let rec x = (print_endline "x"; Tree [y; z]) + and y = (print_endline "y"; Tree []) + and z = (print_endline "z"; Tree [x]) + in + match (x, y, z) with + | (Tree [y1; z1], Tree[], Tree[x1]) -> + assert (y1 == y); + assert (z1 == z); + assert (x1 == x) + | _ -> + assert false diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference new file mode 100644 index 0000000000..f471662b7d --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_1.reference @@ -0,0 +1,3 @@ +y +x +z diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml new file mode 100644 index 0000000000..736f82ad32 --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_2.ml @@ -0,0 +1,18 @@ +(* A variant of evaluation_order_1.ml where the side-effects + are inside the blocks. Note that this changes the evaluation + order, as y is considered recursive. +*) +type tree = Tree of tree list + +let test = + let rec x = (Tree [(print_endline "x"; y); z]) + and y = Tree (print_endline "y"; []) + and z = Tree (print_endline "z"; [x]) + in + match (x, y, z) with + | (Tree [y1; z1], Tree[], Tree[x1]) -> + assert (y1 == y); + assert (z1 == z); + assert (x1 == x) + | _ -> + assert false diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference new file mode 100644 index 0000000000..04ec35a6dc --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_2.reference @@ -0,0 +1,3 @@ +x +y +z diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml new file mode 100644 index 0000000000..8f76a8f858 --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_3.ml @@ -0,0 +1,11 @@ +type t = { x : t; y : t } + +let p = print_endline + +let test = + let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) } + and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) } + in + assert (x.x == x); assert (x.y == y); + assert (y.x == x); assert (y.y == y); + () diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference new file mode 100644 index 0000000000..5b8c549eca --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_3.reference @@ -0,0 +1,6 @@ +x +x_y +x_x +y +y_y +y_x diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml new file mode 100644 index 0000000000..cdfa9d2f85 --- /dev/null +++ b/testsuite/tests/letrec/float_block_1.ml @@ -0,0 +1,10 @@ +(* a bug in cmmgen.ml provokes a change in compilation order between + ocamlc and ocamlopt in certain letrec-bindings involving float + arrays *) +let test = + let rec x = print_endline "x"; [| 1; 2; 3 |] + and y = print_endline "y"; [| 1.; 2.; 3. |] + in + assert (x = [| 1; 2; 3 |]); + assert (y = [| 1.; 2.; 3. |]); + () diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference new file mode 100644 index 0000000000..b77b4eb1d9 --- /dev/null +++ b/testsuite/tests/letrec/float_block_1.reference @@ -0,0 +1,2 @@ +x +y diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml new file mode 100644 index 0000000000..968cba4eb1 --- /dev/null +++ b/testsuite/tests/letrec/float_block_2.ml @@ -0,0 +1,7 @@ +(* a bug in cmmgen.ml provokes a segfault in certain natively compiled + letrec-bindings involving float arrays *) +let test = + let rec x = [| y; y |] and y = 1. in + assert (x = [| 1.; 1. |]); + assert (y = 1.); + () diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml new file mode 100644 index 0000000000..5686e49357 --- /dev/null +++ b/testsuite/tests/letrec/lists.ml @@ -0,0 +1,8 @@ +(* a test with lists, because cyclic lists are fun *) +let test = + let rec li = 0::1::2::3::4::5::6::7::8::9::li in + match li with + | 0::1::2::3::4::5::6::7::8::9:: + 0::1::2::3::4::5::6::7::8::9::li' -> + assert (li == li') + | _ -> assert false diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml new file mode 100644 index 0000000000..e79f79ecbe --- /dev/null +++ b/testsuite/tests/letrec/mixing_value_closures_1.ml @@ -0,0 +1,8 @@ +(* mixing values and closures may exercise interesting code paths *) +type t = A of (int -> int) +let test = + let rec x = A f + and f = function + | 0 -> 2 + | n -> match x with A g -> g 0 + in assert (f 1 = 2) diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml new file mode 100644 index 0000000000..eb5fcb7420 --- /dev/null +++ b/testsuite/tests/letrec/mixing_value_closures_2.ml @@ -0,0 +1,8 @@ +(* a polymorphic variant of test3.ml; found a real bug once *) +let test = + let rec x = `A f + and f = function + | 0 -> 2 + | n -> match x with `A g -> g 0 + in + assert (f 1 = 2) diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml new file mode 100644 index 0000000000..a5b6c51ffe --- /dev/null +++ b/testsuite/tests/letrec/mutual_functions.ml @@ -0,0 +1,11 @@ +(* a simple test with mutually recursive functions *) +let test = + let rec even = function + | 0 -> true + | n -> odd (n - 1) + and odd = function + | 0 -> false + | n -> even (n - 1) + in + List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0))) + [0;1;2;3;4;5;6] -- cgit v1.2.1