Fix global flow analysis

CHANGES.md

@@ -1,6 +1,7 @@
 # Dev (2023-??-??) - ??
 
 * Runtime: fix Dom_html.onIE (#1493)
+* Compiler: fix global flow analysis (#1494)
 
 # 5.4.0 (2023-07-06) - Lille
 

compiler/lib/global_flow.ml

@@ -215,7 +215,9 @@ let expr_deps blocks st x e =
       match st.defs.(Var.idx f) with
       | Expr (Closure (params, _)) when List.length args = List.length params ->
           Hashtbl.add st.applied_functions (x, f) ();
-          if not st.fast then List.iter2 ~f:(fun p a -> add_assign_def st p a) params args;
+          if st.fast
+          then List.iter ~f:(fun a -> do_escape st Escape a) args
+          else List.iter2 ~f:(fun p a -> add_assign_def st p a) params args;
           Var.Set.iter (fun y -> add_dep st x y) (Var.Map.find f st.return_values)
       | _ -> ())
   | Closure (l, cont) ->
@@ -470,8 +472,13 @@ let propagate st ~update approx x =
                       if not (Hashtbl.mem st.applied_functions (x, g))
                       then (
                         Hashtbl.add st.applied_functions (x, g) ();
-                        if not st.fast
+                        if st.fast
                         then
+                          List.iter
+                            ~f:(fun y ->
+                              Domain.variable_escape ~update ~st ~approx Escape y)
+                            args
+                        else
                           List.iter2
                             ~f:(fun p a ->
                               add_assign_def st p a;
@@ -593,7 +600,7 @@ let f ~fast p =
               | Values { known; others } ->
                   Format.fprintf
                     f
-                    "{%a/%b} mut:%b vmut:%b esc:%s"
+                    "{%a/%b} mut:%b vmut:%b vesc:%s esc:%s"
                     (Format.pp_print_list
                        ~pp_sep:(fun f () -> Format.fprintf f ", ")
                        (fun f x ->
@@ -615,6 +622,10 @@ let f ~fast p =
                     others
                     st.possibly_mutable.(Var.idx x)
                     st.variable_possibly_mutable.(Var.idx x)
+                    (match st.variable_may_escape.(Var.idx x) with
+                    | Escape -> "Y"
+                    | Escape_constant -> "y"
+                    | No -> "n")
                     (match st.may_escape.(Var.idx x) with
                     | Escape -> "Y"
                     | Escape_constant -> "y"

compiler/tests-compiler/dune.inc

@@ -359,6 +359,21 @@
  (preprocess
   (pps ppx_expect)))
 
+(library
+ ;; compiler/tests-compiler/gh1494.ml
+ (name gh1494_15)
+ (enabled_if true)
+ (modules gh1494)
+ (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/gh747.ml
  (name gh747_15)

compiler/tests-compiler/gh1494.ml

@@ -0,0 +1,45 @@
+(* Js_of_ocaml tests
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2020 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.
+ *)
+
+(* https://github.com/ocsigen/js_of_ocaml/issues/1007 *)
+
+(* Small bug in the global flow analysis in fast mode *)
+let%expect_test _ =
+  let prog =
+    {|
+let () =
+  let bug () = let g = ref (fun x -> Fun.id) in (fun () -> !g 1), g in
+  let h f =
+    let (h, g) = f() in g := (fun x y -> y); Printf.printf "%d\n" (h () 7) in
+  h bug; h bug
+|}
+  in
+  Util.compile_and_run prog;
+  [%expect {|
+    7
+    7 |}];
+  let program = Util.compile_and_parse prog in
+  Util.print_fun_decl program (Some "bug");
+  [%expect
+    {|
+    function bug(param){
+     var g = [0, function(x){return function(_c_){return _c_;};}];
+     return [0, function(param){return caml_call1(g[1], 1);}, g];
+    }
+    //end |}]