diff options
20 files changed, 170 insertions, 10 deletions
@@ -40,8 +40,7 @@ Standard library: * String: new function "map" (PR#3888) Bug Fixes: -* PR#5467: no extern "C" into ocaml C-stub headers -- PR#4549: Filename.dirname is not handling multiple / on Unix +* PR#4549: Filename.dirname is not handling multiple / on Unix - PR#4869: rare collisions between assembly labels for code and data - PR#4880: "assert" constructs now show up in the exception stack backtrace - PR#5313: ocamlopt -g misses optimizations @@ -62,6 +61,8 @@ Feature wishes: - PR#5411: new directive for the toplevel: #load_rec - PR#5420: Unix.openfile share mode (Windows) - PR#5454: Digest.compare is missing and md5 doc update +- PR#5476: bug in native code compilation of let rec on float arrays +- PR#5467: no extern "C" into ocaml C-stub headers Shedding weight: * Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 28dc3431b..7a7bd211a 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -389,6 +389,7 @@ let fundecls_size fundecls = type rhs_kind = | RHS_block of int + | RHS_floatblock of int | RHS_nonrec ;; let rec expr_size = function @@ -402,6 +403,8 @@ let rec expr_size = function RHS_block (List.length args) | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) + | Uprim(Pmakearray(Pfloatarray), args, _) -> + RHS_floatblock (List.length args) | Usequence(exp, exp') -> expr_size exp' | _ -> RHS_nonrec @@ -1524,25 +1527,29 @@ and transl_switch arg index cases = match Array.length cases with and transl_letrec bindings cont = let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in + let op_alloc prim sz = + Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in let rec init_blocks = function | [] -> fill_nonrec bsz | (id, exp, RHS_block sz) :: rem -> - Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none), - [int_const sz]), - init_blocks rem) + Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) + | (id, exp, RHS_floatblock sz) :: rem -> + Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet (id, transl exp, fill_nonrec rem) and fill_blocks = function | [] -> cont - | (id, exp, RHS_block _) :: rem -> - Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), - [Cvar id; transl exp]), - fill_blocks rem) + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + let op = + Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), + [Cvar id; transl exp]) in + Csequence(op, fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile new file mode 100644 index 000000000..bcc2fdb01 --- /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 000000000..4a893225b --- /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 000000000..a7d033880 --- /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 000000000..71c7880d6 --- /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 000000000..ab713757f --- /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 000000000..5b88844d7 --- /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 000000000..f471662b7 --- /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 000000000..736f82ad3 --- /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 000000000..04ec35a6d --- /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 000000000..8f76a8f85 --- /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 000000000..5b8c549ec --- /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 000000000..cdfa9d2f8 --- /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 000000000..b77b4eb1d --- /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 000000000..968cba4eb --- /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 000000000..5686e4935 --- /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 000000000..e79f79ecb --- /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 000000000..eb5fcb742 --- /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 000000000..a5b6c51ff --- /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] |