diff --git a/CHANGES.md b/CHANGES.md index 756c51cd58..19da1ec27c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,9 @@ #dev ## Features/Changes -* Compiler/wasm: omit code pointer from closures when not used (#2059) +* Compiler/wasm: omit code pointer from closures when not used (#2059, #2093) + +## Bug fixes * Compiler: fix purity of comparison functions (again) (#2092) # 6.2.0 (2025-07-30) - Lille diff --git a/compiler/lib-wasm/call_graph_analysis.ml b/compiler/lib-wasm/call_graph_analysis.ml index 9c721919a1..0332a3feeb 100644 --- a/compiler/lib-wasm/call_graph_analysis.ml +++ b/compiler/lib-wasm/call_graph_analysis.ml @@ -15,11 +15,11 @@ let block_deps ~info ~non_escaping ~ambiguous ~blocks pc = let block = Addr.Map.find pc blocks in List.iter block.body ~f:(fun i -> match i with - | Let (_, Apply { f; _ }) -> ( + | Let (_, Apply { f; exact; _ }) -> ( match get_approx info f with | Top -> () | Values { known; others } -> - if others || Var.Set.cardinal known > 1 + if (not exact) || others || Var.Set.cardinal known > 1 then Var.Set.iter (fun x -> Var.Hashtbl.replace ambiguous x ()) known; if debug () then diff --git a/compiler/tests-wasm_of_ocaml/dune b/compiler/tests-wasm_of_ocaml/dune index ca3ae08d11..4c17507043 100644 --- a/compiler/tests-wasm_of_ocaml/dune +++ b/compiler/tests-wasm_of_ocaml/dune @@ -5,3 +5,12 @@ (flags :standard --disable optcall --no-inline)) (wasm_of_ocaml (flags :standard --disable optcall --no-inline))) + +(tests + (names gh2093) + (modes wasm) + (enabled_if + (>= %{ocaml_version} 5)) + (wasm_of_ocaml + (compilation_mode whole_program) + (flags :standard))) diff --git a/compiler/tests-wasm_of_ocaml/gh2093.expected b/compiler/tests-wasm_of_ocaml/gh2093.expected new file mode 100644 index 0000000000..4104174dde --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh2093.expected @@ -0,0 +1,11 @@ +IN +peform E +OUT +handled E +IN +peform E +OUT +handled E +IN +done +OUT diff --git a/compiler/tests-wasm_of_ocaml/gh2093.ml b/compiler/tests-wasm_of_ocaml/gh2093.ml new file mode 100644 index 0000000000..01881e0289 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh2093.ml @@ -0,0 +1,70 @@ +(* +Copyright (c) 2015, KC Sivaramakrishnan + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +*) + +(* User-land dynamic wind: + http://okmij.org/ftp/continuations/implementations.html#dynamic-wind *) +open Effect +open Effect.Deep + +let dynamic_wind before_thunk thunk after_thunk = + before_thunk (); + let res = + match_with + thunk + () + { retc = Fun.id + ; exnc = + (fun e -> + after_thunk (); + raise e) + ; effc = + (fun (type a) (e : a Effect.t) -> + Some + (fun (k : (a, _) continuation) -> + after_thunk (); + let res' = perform e in + before_thunk (); + continue k res')) + } + in + after_thunk (); + res + +type _ Effect.t += E : unit Effect.t + +let () = + let bt () = Printf.printf "IN\n" in + let at () = Printf.printf "OUT\n" in + let foo () = + Printf.printf "peform E\n"; + perform E; + Printf.printf "peform E\n"; + perform E; + Printf.printf "done\n" + in + try_with + (dynamic_wind bt foo) + at + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | E -> + Some + (fun (k : (a, _) continuation) -> + Printf.printf "handled E\n"; + continue k ()) + | _ -> None) + }