From ac3c3aaf5b4ae88517d6ec41cb85979872c5d7d5 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 20 Sep 2023 17:12:29 +0200 Subject: [PATCH] Start adding tests for double translation --- .../double-translation/direct_calls.ml | 134 ++++++++ .../tests-compiler/double-translation/dune | 14 + .../double-translation/dune.inc | 60 ++++ .../effects_continuations.ml | 312 ++++++++++++++++++ .../double-translation/effects_exceptions.ml | 195 +++++++++++ .../double-translation/effects_toplevel.ml | 94 ++++++ compiler/tests-compiler/util/util.ml | 45 ++- compiler/tests-compiler/util/util.mli | 5 + 8 files changed, 858 insertions(+), 1 deletion(-) create mode 100644 compiler/tests-compiler/double-translation/direct_calls.ml create mode 100644 compiler/tests-compiler/double-translation/dune create mode 100644 compiler/tests-compiler/double-translation/dune.inc create mode 100644 compiler/tests-compiler/double-translation/effects_continuations.ml create mode 100644 compiler/tests-compiler/double-translation/effects_exceptions.ml create mode 100644 compiler/tests-compiler/double-translation/effects_toplevel.ml diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml new file mode 100644 index 0000000000..4299395d1c --- /dev/null +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -0,0 +1,134 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "direct calls with --enable effects,doubletranslate" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + (* Arity of the argument of a function / direct call *) + let test1 () = + let f g x = g x in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x *. 2.) 4.) + + (* Arity of the argument of a function / CPS call *) + let test2 () = + let f g x = g x in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x ^ "a") "a") + + (* Arity of functions in a functor / direct call *) + let test3 x = + let module F(_ : sig end) = struct let f x = x + 1 end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + (M1.f 1, M2.f 2) + + (* Arity of functions in a functor / CPS call *) + let test4 x = + let module F(_ : sig end) = + struct let f x = Printf.printf "%d" x end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + M1.f 1; M2.f 2 +|} + in + print_double_fun_decl code "test1"; + print_double_fun_decl code "test2"; + print_double_fun_decl code "test3"; + print_double_fun_decl code "test4"; + [%expect + {| + function test1$0(param){ + function f(g, x){return caml_doublecall1(g, x);} + var _H_ = 7; + f(function(x){return x + 1 | 0;}, _H_); + var _I_ = 4.; + f(function(x){return x * 2.;}, _I_); + return 0; + } + //end + function test1$1(param, cont){ + function f(g, x){return caml_doublecall1(g, x);} + var _F_ = 7; + f(function(x){return x + 1 | 0;}, _F_); + var _G_ = 4.; + f(function(x){return x * 2.;}, _G_); + return cont(0); + } + //end + var test1 = caml_cps_closure(test1$0, test1$1); + //end + function test2$0(param){ + var f = f$0(); + f(_h_(), 7); + f(_j_(), cst_a); + return 0; + } + //end + function test2$1(param, cont){ + var f = f$0(), _y_ = 7, _z_ = _h_(); + return caml_cps_exact_double_call3 + (f, + _z_, + _y_, + function(_A_){ + var _B_ = _j_(); + return caml_cps_exact_double_call3 + (f, _B_, cst_a, function(_C_){return cont(0);}); + }); + } + //end + var test2 = caml_cps_closure(test2$0, test2$1); + //end + function test3$0(x){ + function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} + var M1 = F([0]), M2 = F([0]), _x_ = caml_doublecall1(M2[1], 2); + return [0, caml_doublecall1(M1[1], 1), _x_]; + } + //end + function test3$1(x, cont){ + function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} + var M1 = F([0]), M2 = F([0]), _w_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _w_]); + } + //end + var test3 = caml_cps_closure(test3$0, test3$1); + //end + function test4$0(x){ + function F(symbol){var f$0 = f(); return [0, f$0];} + var M1 = F([0]), M2 = F([0]); + caml_doublecall1(M1[1], 1); + return caml_doublecall1(M2[1], 2); + } + //end + function test4$1(x, cont){ + function F(symbol){var f$0 = f(); return [0, f$0];} + var M1 = F([0]), M2 = F([0]), _t_ = 1, _u_ = M1[1]; + return caml_cps_exact_double_call2 + (_u_, + _t_, + function(_v_){return caml_cps_exact_double_call2(M2[1], 2, cont);}); + } + //end + var test4 = caml_cps_closure(test4$0, test4$1); + //end |}] diff --git a/compiler/tests-compiler/double-translation/dune b/compiler/tests-compiler/double-translation/dune new file mode 100644 index 0000000000..063207b8a9 --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune @@ -0,0 +1,14 @@ +(include dune.inc) + +(rule + (deps + (glob_files *.ml)) + (action + (with-stdout-to + dune.inc.gen + (run ../gen-rules/gen.exe jsoo_compiler_test)))) + +(rule + (alias runtest) + (action + (diff dune.inc dune.inc.gen))) diff --git a/compiler/tests-compiler/double-translation/dune.inc b/compiler/tests-compiler/double-translation/dune.inc new file mode 100644 index 0000000000..1cecd7aa8b --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune.inc @@ -0,0 +1,60 @@ + +(library + ;; compiler/tests-compiler/double-translation/direct_calls.ml + (name direct_calls_47) + (enabled_if true) + (modules direct_calls) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_continuations.ml + (name effects_continuations_47) + (enabled_if true) + (modules effects_continuations) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_exceptions.ml + (name effects_exceptions_47) + (enabled_if true) + (modules effects_exceptions) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_toplevel.ml + (name effects_toplevel_47) + (enabled_if true) + (modules effects_toplevel) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml new file mode 100644 index 0000000000..a8f2c9dc6a --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -0,0 +1,312 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + (* Conditional whose result is used *) + let cond1 b = + let ic = if b then open_in "toto" else open_in "titi" in + (ic , 7) + + (* Conditional whose result is not used *) + let cond2 b = + if b then Printf.eprintf "toto" else Printf.eprintf "toto"; + 7 + + (* A dummy argument is used to call the continuation in the + [then] clause *) + let cond3 b = + let x= ref 0 in if b then x := 1 else Printf.eprintf "toto"; + !x + + (* Two continuation functions are created. One to bind [ic] before + entering the loop, and one for the loop. We use a dummy argument + to go back to the begining of the loop if [b] is false *) + let loop1 b = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + while true do + let line = input_line ic in + all := line :: !all; + if b then prerr_endline line + done + + (* There is a single continuation for the loop since the result of + [Printf.eprintf] is ignored. *) + let loop2 () = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + Printf.eprintf "titi"; + while true do + let line = input_line ic in + all := line :: !all; + prerr_endline line + done + + let loop3 () = + let l = List.rev [1;2;3] in + let rec f x = + match x with + | [] -> l + | _ :: r -> f r + in + f l + |} + in + print_double_fun_decl code "exceptions"; + print_double_fun_decl code "cond1"; + print_double_fun_decl code "cond2"; + print_double_fun_decl code "cond3"; + print_double_fun_decl code "loop1"; + print_double_fun_decl code "loop2"; + print_double_fun_decl code "loop3"; + [%expect + {| + + function exceptions$0(s){ + try{var _T_ = caml_int_of_string(s), n = _T_;} + catch(_W_){ + var _M_ = caml_wrap_exception(_W_); + if(_M_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_M_, 0); + var n = 0, _N_ = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _S_ = 7, m = _S_; + } + catch(_V_){ + var _O_ = caml_wrap_exception(_V_); + if(_O_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_O_, 0); + var m = 0, _P_ = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _R_ = [0, [0, caml_doublecall1(Stdlib[79], cst_toto), n, m]]; + return _R_; + } + catch(_U_){ + var _Q_ = caml_wrap_exception(_U_); + if(_Q_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_Q_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _H_ = caml_int_of_string(s), n = _H_;} + catch(_L_){ + var _C_ = caml_wrap_exception(_L_); + if(_C_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_C_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _G_ = 7, m = _G_; + } + catch(_K_){ + var _D_ = caml_wrap_exception(_K_); + if(_D_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_D_, 0)); + } + var m = 0; + } + runtime.caml_push_trap + (function(_J_){ + if(_J_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_J_, 0)); + }); + if(caml_string_equal(s, cst)){ + var _E_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_E_, 1)); + } + var _F_ = Stdlib[79]; + return caml_cps_call2 + (_F_, + cst_toto, + function(_I_){caml_pop_trap(); return cont([0, [0, _I_, n, m]]);}); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end + function cond1$0(b){ + var + ic = + b + ? caml_doublecall1(Stdlib[79], cst_toto$0) + : caml_doublecall1(Stdlib[79], cst_titi); + return [0, ic, 7]; + } + //end + function cond1$1(b, cont){ + function _B_(ic){return cont([0, ic, 7]);} + return b + ? caml_cps_call2(Stdlib[79], cst_toto$0, _B_) + : caml_cps_call2(Stdlib[79], cst_titi, _B_); + } + //end + var cond1 = caml_cps_closure(cond1$0, cond1$1); + //end + function cond2$0(b){ + if(b) + caml_doublecall1(Stdlib_Printf[3], _h_); + else + caml_doublecall1(Stdlib_Printf[3], _i_); + return 7; + } + //end + function cond2$1(b, cont){ + function _z_(_A_){return cont(7);} + return b + ? caml_cps_call2(Stdlib_Printf[3], _h_, _z_) + : caml_cps_call2(Stdlib_Printf[3], _i_, _z_); + } + //end + var cond2 = caml_cps_closure(cond2$0, cond2$1); + //end + function cond3$0(b){ + var x = [0, 0]; + if(b) x[1] = 1; else caml_doublecall1(Stdlib_Printf[3], _j_); + return x[1]; + } + //end + function cond3$1(b, cont){ + var x = [0, 0]; + function _x_(_y_){return cont(x[1]);} + return b ? (x[1] = 1, _x_(0)) : caml_cps_call2(Stdlib_Printf[3], _j_, _x_); + } + //end + var cond3 = caml_cps_closure(cond3$0, cond3$1); + //end + function loop1$0(b){ + var all = [0, 0], ic = caml_doublecall1(Stdlib[79], cst_static_examples_ml); + for(;;){ + var line = caml_doublecall1(Stdlib[83], ic); + all[1] = [0, line, all[1]]; + if(! b) continue; + caml_doublecall1(Stdlib[53], line); + } + } + //end + function loop1$1(b, cont){ + var all = [0, 0], _t_ = Stdlib[79]; + return caml_cps_call2 + (_t_, + cst_static_examples_ml, + function(ic){ + function _u_(_w_){ + var _v_ = Stdlib[83]; + return caml_cps_call2 + (_v_, + ic, + function(line){ + all[1] = [0, line, all[1]]; + return b + ? caml_cps_call2(Stdlib[53], line, _u_) + : caml_cps_exact_call1(_u_, 0); + }); + } + return _u_(0); + }); + } + //end + var loop1 = caml_cps_closure(loop1$0, loop1$1); + //end + function loop2$0(param){ + var + all = [0, 0], + ic = caml_doublecall1(Stdlib[79], cst_static_examples_ml$0); + caml_doublecall1(Stdlib_Printf[3], _k_); + for(;;){ + var line = caml_doublecall1(Stdlib[83], ic); + all[1] = [0, line, all[1]]; + caml_doublecall1(Stdlib[53], line); + } + } + //end + function loop2$1(param, cont){ + var all = [0, 0], _o_ = Stdlib[79]; + return caml_cps_call2 + (_o_, + cst_static_examples_ml$0, + function(ic){ + var _p_ = Stdlib_Printf[3]; + function _q_(_s_){ + var _r_ = Stdlib[83]; + return caml_cps_call2 + (_r_, + ic, + function(line){ + all[1] = [0, line, all[1]]; + return caml_cps_call2(Stdlib[53], line, _q_); + }); + } + return caml_cps_call2(_p_, _k_, _q_); + }); + } + //end + var loop2 = caml_cps_closure(loop2$0, loop2$1); + //end + function loop3$0(param){ + var l = caml_doublecall1(Stdlib_List[9], _l_), x = l; + for(;;){if(! x) return l; var r = x[2], x = r;} + } + //end + function loop3$1(param, cont){ + var _m_ = Stdlib_List[9]; + return caml_cps_call2 + (_m_, + _l_, + function(l){ + function _n_(x){ + if(! x) return cont(l); + var r = x[2]; + return caml_cps_exact_call1(_n_, r); + } + return _n_(l); + }); + } + //end + var loop3 = caml_cps_closure(loop3$0, loop3$1); + //end |}] diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml new file mode 100644 index 0000000000..de0ee9a8c3 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -0,0 +1,195 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + let handler_is_loop f g l = + try f () + with exn -> + let rec loop l = + match g l with + | `Fallback l' -> loop l' + | `Raise exn -> raise exn + in + loop l + + let handler_is_merge_node g = + let s = try g () with _ -> "" in + s ^ "aaa" + |} + in + print_double_fun_decl code "exceptions"; + [%expect + {| + + function exceptions$0(s){ + try{var _G_ = caml_int_of_string(s), n = _G_;} + catch(_J_){ + var _z_ = caml_wrap_exception(_J_); + if(_z_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_z_, 0); + var n = 0, _A_ = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _F_ = 7, m = _F_; + } + catch(_I_){ + var _B_ = caml_wrap_exception(_I_); + if(_B_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_B_, 0); + var m = 0, _C_ = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _E_ = [0, [0, caml_doublecall1(Stdlib[79], cst_toto), n, m]]; + return _E_; + } + catch(_H_){ + var _D_ = caml_wrap_exception(_H_); + if(_D_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_D_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _u_ = caml_int_of_string(s), n = _u_;} + catch(_y_){ + var _p_ = caml_wrap_exception(_y_); + if(_p_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_p_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _t_ = 7, m = _t_; + } + catch(_x_){ + var _q_ = caml_wrap_exception(_x_); + if(_q_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_q_, 0)); + } + var m = 0; + } + caml_push_trap + (function(_w_){ + if(_w_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_w_, 0)); + }); + if(caml_string_equal(s, cst)){ + var _r_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_r_, 1)); + } + var _s_ = Stdlib[79]; + return caml_cps_call2 + (_s_, + cst_toto, + function(_v_){caml_pop_trap(); return cont([0, [0, _v_, n, m]]);}); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end |}]; + print_double_fun_decl code "handler_is_loop"; + [%expect + {| + function handler_is_loop$0(f, g, l){ + try{var _n_ = caml_doublecall1(f, 0); return _n_;} + catch(_o_){ + var l$0 = l; + for(;;){ + var match = caml_doublecall1(g, l$0); + if(72330306 <= match[1]){var l$1 = match[2], l$0 = l$1; continue;} + var exn = match[2]; + throw caml_maybe_attach_backtrace(exn, 1); + } + } + } + //end + function handler_is_loop$1(f, g, l, cont){ + caml_push_trap + (function(_l_){ + function _m_(l){ + return caml_cps_call2 + (g, + l, + function(match){ + if(72330306 <= match[1]){ + var l = match[2]; + return caml_cps_exact_call1(_m_, l); + } + var + exn = match[2], + raise = caml_pop_trap(), + exn$0 = caml_maybe_attach_backtrace(exn, 1); + return raise(exn$0); + }); + } + return _m_(l); + }); + var _j_ = 0; + return caml_cps_call2 + (f, _j_, function(_k_){caml_pop_trap(); return cont(_k_);}); + } + //end + var handler_is_loop = caml_cps_closure(handler_is_loop$0, handler_is_loop$1); + //end |}]; + print_double_fun_decl code "handler_is_merge_node"; + [%expect + {| + function handler_is_merge_node$0(g){ + try{var _h_ = caml_doublecall1(g, 0), s = _h_;}catch(_i_){var s = cst$1;} + return caml_doublecall2(Stdlib[28], s, cst_aaa); + } + //end + function handler_is_merge_node$1(g, cont){ + function _e_(s){return caml_cps_call3(Stdlib[28], s, cst_aaa, cont);} + caml_push_trap(function(_g_){return _e_(cst$1);}); + var _d_ = 0; + return caml_cps_call2 + (g, _d_, function(_f_){caml_pop_trap(); return _e_(_f_);}); + } + //end + var + handler_is_merge_node = + caml_cps_closure(handler_is_merge_node$0, handler_is_merge_node$1); + //end |}] diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml new file mode 100644 index 0000000000..ddd5502d97 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -0,0 +1,94 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + {| + (* Function calls at toplevel outside of loops use + [caml_callback]. *) + let g () = Printf.printf "abc" in + let f () = for i = 1 to 5 do g () done in + g (); f (); g () + |} + in + print_program code; + [%expect + {| + + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + caml_callback = runtime.caml_callback, + caml_string_of_jsbytes = runtime.caml_string_of_jsbytes; + function caml_cps_exact_call1(f, a0){ + return runtime.caml_stack_check_depth() + ? f(a0) + : runtime.caml_trampoline_return(f, [a0]); + } + function caml_cps_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? (f.l + >= 0 + ? f.l + : f.l = f.length) + == 2 + ? f(a0, a1) + : runtime.caml_call_gen(f, [a0, a1]) + : runtime.caml_trampoline_return(f, [a0, a1]); + } + function caml_cps_exact_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? f(a0, a1) + : runtime.caml_trampoline_return(f, [a0, a1]); + } + var + global_data = runtime.caml_get_global_data(), + Stdlib_Printf = global_data.Stdlib__Printf, + _b_ = + [0, + [11, caml_string_of_jsbytes("abc"), 0], + caml_string_of_jsbytes("abc")]; + function g(param, cont){ + return caml_cps_call2(Stdlib_Printf[2], _b_, cont); + } + caml_callback(g, [0]); + var _c_ = 1; + function _d_(i){ + var _e_ = 0; + return caml_cps_exact_call2 + (g, + _e_, + function(_f_){ + var _g_ = i + 1 | 0; + if(5 !== i) return caml_cps_exact_call1(_d_, _g_); + caml_callback(g, [0]); + var Test = [0]; + runtime.caml_register_global(2, Test, "Test"); + return; + }); + } + return _d_(_c_); + } + (globalThis)); + //end |}] diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index 6ee6908049..5649b75685 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -291,6 +291,7 @@ let compile_to_javascript ?(flags = []) ?(use_js_string = false) ?(effects = false) + ?(doubletranslate = false) ~pretty ~sourcemap file = @@ -300,6 +301,7 @@ let compile_to_javascript [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) ; (if effects then [ "--enable=effects" ] else [ "--disable=effects" ]) + ; (if doubletranslate then [ "--enable=doubletranslate" ] else [ "--disable=doubletranslate" ]) ; (if use_js_string then [ "--enable=use-js-string" ] else [ "--disable=use-js-string" ]) @@ -352,6 +354,7 @@ let compile_bc_to_javascript let compile_cmo_to_javascript ?(flags = []) ?effects + ?doubletranslate ?use_js_string ?(pretty = true) ?(sourcemap = true) @@ -359,6 +362,7 @@ let compile_cmo_to_javascript Filetype.path_of_cmo_file file |> compile_to_javascript ?effects + ?doubletranslate ?use_js_string ~flags:([ "--disable"; "header" ] @ flags) ~pretty @@ -494,6 +498,44 @@ let print_fun_decl program n = | [] -> print_endline "not found" | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) +(* Find a doubly-translated function by name, and use the call to [caml_cps_closure] to find the direct-style and CPS closures *) +class find_double_function_declaration r n = + object + inherit Jsoo.Js_traverse.map as super + + method! statement s = + let open Jsoo.Javascript in + (match s with + | Variable_statement (_, l) -> + List.iter l ~f:(function + | DeclIdent + ( S { name = Utf8 name; _ } + , Some ((ECall (EVar (S { name = Utf8 "caml_cps_closure"; _ }), _, [ Arg e1; Arg e2 ], _)), _) ) as var_decl -> ( + let decls = var_decl, e1, e2 in + if String.equal name n then r := decls :: !r else ()) + | _ -> ()) + | _ -> ()); + super#statement s + end + +let print_double_fun_decl program n = + let r = ref [] in + let o = new find_double_function_declaration r n in + ignore (o#program program); + let module J = Jsoo.Javascript in + let maybe_print_decl = function + | J.EFun _ -> () + | J.(EVar (S { name = Utf8 name; _ })) -> print_fun_decl program (Some name) + | _ -> print_endline "not found" + in + match !r with + | [ var_decl, e1, e2 ] -> + maybe_print_decl e1; + maybe_print_decl e2; + print_string (program_to_string [ J.(Variable_statement (Var, [ var_decl ]), N) ]) + | [] -> print_endline "not found" + | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) + let compile_and_run_bytecode ?unix s = with_temp_dir ~f:(fun () -> s @@ -561,7 +603,7 @@ let compile_and_parse_whole_program ?(debug = true) ?flags ?effects ?use_js_stri ~sourcemap:debug |> parse_js) -let compile_and_parse ?(debug = true) ?flags ?effects ?use_js_string s = +let compile_and_parse ?(debug = true) ?flags ?effects ?doubletranslate ?use_js_string s = with_temp_dir ~f:(fun () -> s |> Filetype.ocaml_text_of_string @@ -570,6 +612,7 @@ let compile_and_parse ?(debug = true) ?flags ?effects ?use_js_string s = |> compile_cmo_to_javascript ?flags ?effects + ?doubletranslate ?use_js_string ~pretty:true ~sourcemap:debug diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli index 5cdf488398..65116c3b78 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -35,6 +35,7 @@ val compile_lib : Filetype.cmo_file list -> string -> Filetype.cmo_file val compile_cmo_to_javascript : ?flags:string list -> ?effects:bool + -> ?doubletranslate:bool -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -71,6 +72,9 @@ val print_var_decl : Javascript.program -> string -> unit val print_fun_decl : Javascript.program -> string option -> unit +(* Prints the two versions of a doubly translated function *) +val print_double_fun_decl : Javascript.program -> string -> unit + val compile_and_run : ?debug:bool -> ?skip_modern:bool @@ -87,6 +91,7 @@ val compile_and_parse : ?debug:bool -> ?flags:string list -> ?effects:bool + -> ?doubletranslate:bool -> ?use_js_string:bool -> string -> Javascript.program