diff --git a/CHANGES.md b/CHANGES.md index 83b2dab691..1afc87393e 100644 --- a/CHANGES.md +++ b/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 diff --git a/compiler/lib/dgraph.ml b/compiler/lib/dgraph.ml index 5f190a8fe8..8220fb2352 100644 --- a/compiler/lib/dgraph.ml +++ b/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; diff --git a/compiler/lib/dgraph.mli b/compiler/lib/dgraph.mli index d611be77ee..1ac8ed4d03 100644 --- a/compiler/lib/dgraph.mli +++ b/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 diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 4867797201..551761a70c 100644 --- a/compiler/lib/global_flow.ml +++ b/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,6 +568,33 @@ 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 @@ -575,7 +602,19 @@ let solver st = (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 diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 27e0cd65fb..1559573152 100644 --- a/compiler/tests-compiler/dune.inc +++ b/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) diff --git a/compiler/tests-compiler/gh1768.ml b/compiler/tests-compiler/gh1768.ml new file mode 100644 index 0000000000..4ef6ad25e7 --- /dev/null +++ b/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 |}]