Fix global data flow analysis

CHANGES.md

@@ -5,6 +5,9 @@
 * Test: use dune test stanzas (#1631)
 * Merged Wasm_of_ocaml (#1724)
 
+## Bug fixes
+* Fix small bug in global data flow analysis (#1768)
+
 # 5.9.1 (02-12-2024) - Lille
 
 ## Features/Changes

compiler/lib/dgraph.ml

@@ -258,6 +258,18 @@ struct
       List.iter ~f:(fun x -> Queue.push x queue) !lst;
       { queue; set = to_visit }
 
+    let check g v f report =
+      let update ~children:_ _ = () in
+      NSet.iter
+        (fun x ->
+          let a = NTbl.get v x in
+          let b = f ~update v x in
+          if not (D.equal a b)
+          then (
+            NTbl.set v x b;
+            report x a b))
+        g.domain
+
     let f' size g f =
       n := 0;
       m := 0;

compiler/lib/dgraph.mli

@@ -102,6 +102,13 @@ module Make_Imperative
       -> t
       -> (update:(children:bool -> N.t -> unit) -> D.t NTbl.t -> N.t -> D.t)
       -> D.t NTbl.t
+
+    val check :
+         t
+      -> D.t NTbl.t
+      -> (update:(children:bool -> N.t -> unit) -> D.t NTbl.t -> N.t -> D.t)
+      -> (N.t -> D.t -> D.t -> unit)
+      -> unit
   end
 end
 

compiler/lib/global_flow.ml

@@ -436,11 +436,11 @@ let propagate st ~update approx x =
                          | Some tags -> List.memq t ~set:tags
                          | None -> true ->
                       let t = a.(n) in
+                      let m = Var.ISet.mem st.possibly_mutable z in
+                      if not m then add_dep st x z;
                       add_dep st x t;
                       let a = Var.Tbl.get approx t in
-                      if Var.ISet.mem st.possibly_mutable z
-                      then Domain.join ~update ~st ~approx Domain.others a
-                      else a
+                      if m then Domain.join ~update ~st ~approx Domain.others a else a
                   | Expr (Block _ | Closure _) -> Domain.bot
                   | Phi _ | Expr _ -> assert false)
                 known
@@ -464,6 +464,8 @@ let propagate st ~update approx x =
                   (fun z ->
                     match st.defs.(Var.idx z) with
                     | Expr (Block (_, lst, _, _)) ->
+                        let m = Var.ISet.mem st.possibly_mutable z in
+                        if not m then add_dep st x z;
                         Array.iter ~f:(fun t -> add_dep st x t) lst;
                         let a =
                           Array.fold_left
@@ -472,9 +474,7 @@ let propagate st ~update approx x =
                             ~init:Domain.bot
                             lst
                         in
-                        if Var.ISet.mem st.possibly_mutable z
-                        then Domain.join ~update ~st ~approx Domain.others a
-                        else a
+                        if m then Domain.join ~update ~st ~approx Domain.others a else a
                     | Expr (Closure _) -> Domain.bot
                     | Phi _ | Expr _ -> assert false)
                   known
@@ -568,14 +568,53 @@ let propagate st ~update approx x =
 module G = Dgraph.Make_Imperative (Var) (Var.ISet) (Var.Tbl)
 module Solver = G.Solver (Domain)
 
+let print_approx st f a =
+  match a with
+  | Top -> Format.fprintf f "top"
+  | Values { known; others } ->
+      Format.fprintf
+        f
+        "{%a/%b}"
+        (Format.pp_print_list
+           ~pp_sep:(fun f () -> Format.fprintf f ", ")
+           (fun f x ->
+             Format.fprintf
+               f
+               "%a(%s)"
+               Var.print
+               x
+               (match st.defs.(Var.idx x) with
+               | Expr (Closure _) -> "C"
+               | Expr (Block _) -> (
+                   "B"
+                   ^
+                   match st.may_escape.(Var.idx x) with
+                   | Escape -> "X"
+                   | _ -> "")
+               | _ -> "O")))
+        (Var.Set.elements known)
+        others
+
 let solver st =
   let g =
     { G.domain = st.vars
     ; G.iter_children =
         (fun f x -> Var.Tbl.DataSet.iter (fun k -> f k) (Var.Tbl.get st.deps x))
     }
   in
-  Solver.f' () g (propagate st)
+  let res = Solver.f' () g (propagate st) in
+  if debug ()
+  then
+    Solver.check g res (propagate st) (fun x a b ->
+        Format.eprintf
+          "Incorrect value: %a: %a -> %a@."
+          Var.print
+          x
+          (print_approx st)
+          a
+          (print_approx st)
+          b);
+  res
 
 (****)
 
@@ -635,29 +674,12 @@ let f ~fast p =
             (fun f a ->
               match a with
               | Top -> Format.fprintf f "top"
-              | Values { known; others } ->
+              | Values _ ->
                   Format.fprintf
                     f
-                    "{%a/%b} mut:%b vmut:%b vesc:%s esc:%s"
-                    (Format.pp_print_list
-                       ~pp_sep:(fun f () -> Format.fprintf f ", ")
-                       (fun f x ->
-                         Format.fprintf
-                           f
-                           "%a(%s)"
-                           Var.print
-                           x
-                           (match st.defs.(Var.idx x) with
-                           | Expr (Closure _) -> "C"
-                           | Expr (Block _) -> (
-                               "B"
-                               ^
-                               match st.may_escape.(Var.idx x) with
-                               | Escape -> "X"
-                               | _ -> "")
-                           | _ -> "O")))
-                    (Var.Set.elements known)
-                    others
+                    "%a mut:%b vmut:%b vesc:%s esc:%s"
+                    (print_approx st)
+                    a
                     (Var.ISet.mem st.possibly_mutable x)
                     (Var.ISet.mem st.variable_possibly_mutable x)
                     (match st.variable_may_escape.(Var.idx x) with

compiler/tests-compiler/dune.inc

@@ -434,6 +434,21 @@
  (preprocess
   (pps ppx_expect)))
 
+(library
+ ;; compiler/tests-compiler/gh1768.ml
+ (name gh1768_15)
+ (enabled_if true)
+ (modules gh1768)
+ (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/gh1768.ml

@@ -0,0 +1,76 @@
+(* Js_of_ocaml tests
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2024 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/pull/1768 *)
+
+let%expect_test _ =
+  let prog =
+    {|
+let () =
+  let h x = x := (fun x y -> x + y) in
+  let f () = ref (fun _ -> assert false) in
+  let x = f() in
+  let g () = !x 7 in
+  h x;
+  assert (g () 3 = 10)
+|}
+  in
+  let program =
+    Util.compile_and_parse
+      ~flags:(List.concat [ [ "--opt"; "3" ]; [ "--no-inline" ] ])
+      prog
+  in
+  Util.print_program program;
+  [%expect
+    {|
+    (function(globalThis){
+       "use strict";
+       var
+        runtime = globalThis.jsoo_runtime,
+        caml_maybe_attach_backtrace = runtime.caml_maybe_attach_backtrace,
+        caml_string_of_jsbytes = runtime.caml_string_of_jsbytes;
+       function caml_call1(f, a0){
+        return (f.l >= 0 ? f.l : f.l = f.length) === 1
+                ? f(a0)
+                : runtime.caml_call_gen(f, [a0]);
+       }
+       var
+        dummy = 0,
+        global_data = runtime.caml_get_global_data(),
+        Assert_failure = global_data.Assert_failure,
+        _a_ = [0, caml_string_of_jsbytes("test.ml"), 4, 27],
+        _b_ = [0, caml_string_of_jsbytes("test.ml"), 8, 2];
+       function h(x){x[1] = function(x, y){return x + y | 0;};}
+       function f(param){
+        return [0,
+                function(param){
+                 throw caml_maybe_attach_backtrace([0, Assert_failure, _a_], 1);
+                }];
+       }
+       var x = f();
+       function g(param){return caml_call1(x[1], 7);}
+       h(x);
+       if(10 !== caml_call1(g(), 3))
+        throw caml_maybe_attach_backtrace([0, Assert_failure, _b_], 1);
+       var Test = [0];
+       runtime.caml_register_global(3, Test, "Test");
+       return;
+      }
+      (globalThis));
+    //end |}]