diff --git a/CHANGES.md b/CHANGES.md index d6115d8040..73e287eba1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -23,6 +23,7 @@ ## Bug fixes * Compiler: fix rewriter bug in share_constant (fix #1247) +* Compiler: fix miscompilation of mutually recursive functions in loop (#1321) * Runtime: fix ocamlyacc parse engine (#1307) * Runtime: fix Out_channel.is_buffered, set_buffered * Runtime: fix format wrt alternative diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index e5ed9dc7ed..86d2f461cf 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -27,7 +27,7 @@ type closure_info = ; args : Code.Var.t list ; cont : Code.cont ; tc : Code.Addr.Set.t Code.Var.Map.t - ; ntc : Code.Addr.Set.t Code.Var.Map.t + ; mutated_vars : Code.Var.Set.t } type 'a int_ext = @@ -41,9 +41,9 @@ let add_multi k v map = let set = try Var.Map.find k map with Not_found -> Addr.Set.empty in Var.Map.add k (Addr.Set.add v set) map -let rec collect_apply pc blocks visited tc ntc = +let rec collect_apply pc blocks visited tc = if Addr.Set.mem pc visited - then visited, tc, ntc + then visited, tc else let visited = Addr.Set.add pc visited in let block = Addr.Map.find pc blocks in @@ -57,32 +57,22 @@ let rec collect_apply pc blocks visited tc ntc = | Some _ -> None) | _ -> None in - let visited, ntc = - List.fold_left block.body ~init:(visited, ntc) ~f:(fun (visited, acc) x -> - match x with - | Let (_, Apply (z, _, _)) -> visited, add_multi z pc acc - | Let (_, Closure (_, (pc, _))) -> - let visited, _tc, ntc = collect_apply pc blocks visited tc ntc in - visited, ntc - | _ -> visited, acc) - in match tc_opt with - | Some tc -> visited, tc, ntc + | Some tc -> visited, tc | None -> Code.fold_children blocks pc - (fun pc (visited, tc, ntc) -> collect_apply pc blocks visited tc ntc) - (visited, tc, ntc) + (fun pc (visited, tc) -> collect_apply pc blocks visited tc) + (visited, tc) -let rec collect_closures blocks l = +let rec collect_closures blocks mutated_vars l = match l with | Let (f_name, Closure (args, ((pc, _) as cont))) :: rem -> - let _, tc, ntc = - collect_apply pc blocks Addr.Set.empty Var.Map.empty Var.Map.empty - in - let l, rem = collect_closures blocks rem in - { f_name; args; cont; tc; ntc } :: l, rem + let _, tc = collect_apply pc blocks Addr.Set.empty Var.Map.empty in + let l, rem = collect_closures blocks mutated_vars rem in + let mutated_vars = Addr.Map.find pc mutated_vars in + { f_name; args; cont; tc; mutated_vars } :: l, rem | rem -> [], rem let group_closures ~tc_only closures_map = @@ -93,14 +83,7 @@ let group_closures ~tc_only closures_map = Var.Map.fold (fun _ x graph -> let calls = Var.Map.fold (fun x _ tc -> Var.Set.add x tc) x.tc Var.Set.empty in - let calls = - if tc_only - then calls - else - Var.Set.union - calls - (Var.Map.fold (fun x _ ntc -> Var.Set.add x ntc) x.ntc Var.Set.empty) - in + let calls = if tc_only then calls else Var.Set.union calls x.mutated_vars in Var.Map.add x.f_name (Var.Set.inter names calls) graph) closures_map Var.Map.empty @@ -401,7 +384,7 @@ let rec rewrite_closures mutated_vars rewrite_list free_pc blocks body : int * _ = match body with | Let (_, Closure _) :: _ -> - let closures, rem = collect_closures blocks body in + let closures, rem = collect_closures blocks mutated_vars body in let closures_map = List.fold_left closures ~init:Var.Map.empty ~f:(fun closures_map x -> Var.Map.add x.f_name x closures_map) diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 54d3bef674..431f39e7ba 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -168,6 +168,19 @@ (preprocess (pps ppx_expect))) +(library + (name jsooexp_gh1320) + (modules gh1320) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (flags -allow-output-patterns) + (deps + (file ../../compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file ../../compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + (library (name jsooexp_gl507) (modules gl507) diff --git a/compiler/tests-compiler/gh1320.ml b/compiler/tests-compiler/gh1320.ml new file mode 100644 index 0000000000..b98dcc7000 --- /dev/null +++ b/compiler/tests-compiler/gh1320.ml @@ -0,0 +1,63 @@ +(* Js_of_ocaml tests + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2022 Hugo Heuzard, Jérôme Vouillon + * + * 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. + *) + +(* https://github.com/ocsigen/js_of_ocaml/issues/1320 *) + +let%expect_test _ = + let prog = + {| +let app f x = f x + +let myfun () = + for i = 1 to 4 do + let rec f x = if x = 0 then 1 else i * app g (x - 1) and g x = app f x in + Format.eprintf "%d@." (g i) + done + +let () = myfun () +|} + in + Util.compile_and_run prog; + [%expect + {| + 1 + 4 + 27 + 256 |}]; + let program = Util.compile_and_parse prog in + Util.print_fun_decl program (Some "myfun"); + [%expect + {| + function myfun(param) + {var i=1; + for(;;) + {var + closures= + function(i) + {function g(x){return app(f,x)} + function f(x){return 0 === x?1:runtime.caml_mul(i,app(g,x - 1 | 0))} + var block=[0,g,f]; + return block}, + closures$0=closures(i), + g=closures$0[1], + _b_=g(i); + caml_call2(Stdlib_Format[131],_a_,_b_); + var _c_=i + 1 | 0; + if(4 !== i){var i=_c_;continue} + return 0}} |}]