fix #1320

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

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)

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)

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}} |}]