diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 4efc9bb7de..728cf7e7bb 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1349,6 +1349,36 @@ and compile_block st queue (pc : Addr.t) frontier interm = try Var.Map.find x m with Not_found -> x in let handler = compile_block st [] pc2 inner_frontier new_interm in + if debug () then Format.eprintf "}@]@ "; + Addr.Set.iter (decr_preds st) grey; + let after, exn_escape = + if not (Addr.Set.is_empty grey') + then + let pc = Addr.Set.choose grey' in + let exn_escape = + let x' = Var.fork x in + let found = ref false in + let map_var y = + if Code.Var.equal x y + then ( + found := true; + x') + else y + in + let subst_block pc blocks = + Addr.Map.add pc (Subst.block map_var (Addr.Map.find pc blocks)) blocks + in + let blocks = + Code.traverse Code.fold_children subst_block pc st.blocks st.blocks + in + if !found then st.blocks <- blocks; + if !found then Some x' else None + in + if Addr.Set.mem pc frontier + then [], exn_escape + else compile_block st [] pc frontier interm, exn_escape + else [], None + in let handler = if st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap () then @@ -1367,20 +1397,17 @@ and compile_block st queue (pc : Addr.t) frontier interm = :: handler else handler in - if debug () then Format.eprintf "}@]@ "; - Addr.Set.iter (decr_preds st) grey; + let handler = + match exn_escape with + | Some x' -> + handler @ [J.Variable_statement [J.V x', Some (EVar (J.V x), J.N)], J.N] + | None -> handler + in flush_all queue (( J.Try_statement (body, Some (J.V x, handler), None) , source_location st.ctx pc ) - :: - (if not (Addr.Set.is_empty grey') - then - let pc = Addr.Set.choose grey' in - if Addr.Set.mem pc frontier - then [] - else compile_block st [] pc frontier interm - else [])) + :: after) | _ -> let new_frontier, new_interm = colapse_frontier st new_frontier interm in assert (Addr.Set.cardinal new_frontier <= 1); diff --git a/compiler/lib/js_assign.ml b/compiler/lib/js_assign.ml index dc1b10051e..8609187780 100644 --- a/compiler/lib/js_assign.ml +++ b/compiler/lib/js_assign.ml @@ -361,8 +361,11 @@ let program' (module Strategy : Strategy) p = mapper#block []; if S.cardinal mapper#get_free <> 0 then - failwith_ "Some variables escaped (#%d)" (S.cardinal mapper#get_free) - (* S.iter(fun s -> (Format.eprintf "%s@." (Var.to_string s))) coloring#get_free *); + if true + then failwith_ "Some variables escaped (#%d)" (S.cardinal mapper#get_free) + else ( + Format.eprintf "Some variables escaped (#%d)" (S.cardinal mapper#get_free); + S.iter (fun s -> Format.eprintf "%s@." (Var.to_string s)) mapper#get_free); let names = Strategy.allocate_variables state ~count:mapper#state.Js_traverse.count in (* if debug () then output_debug_information state coloring#state.Js_traverse.count; *) let color = function diff --git a/compiler/lib/subst.mli b/compiler/lib/subst.mli index 873d83fd6c..557cb5d414 100644 --- a/compiler/lib/subst.mli +++ b/compiler/lib/subst.mli @@ -28,6 +28,8 @@ val instr : (Var.t -> Var.t) -> instr -> instr val instrs : (Var.t -> Var.t) -> instr list -> instr list +val block : (Var.t -> Var.t) -> block -> block + val last : (Var.t -> Var.t) -> last -> last val cont : (Var.t -> Var.t) -> int -> program -> program diff --git a/compiler/tests/array_access.ml b/compiler/tests/array_access.ml index c30cecf139..fc1386120e 100644 --- a/compiler/tests/array_access.ml +++ b/compiler/tests/array_access.ml @@ -39,11 +39,11 @@ let%expect_test "array_set" = |> parse_js in let program = compile array_set in - print_fun_decl program "some_name"; + print_fun_decl program (Some "some_name"); [%expect {| function some_name(a,n){runtime.caml_check_bound(a,n)[1 + n] = n;return 1} |}] let%expect_test "array_set" = compile_and_run array_set; - [%expect {||}] + [%expect {| |}] diff --git a/compiler/tests/eliminate_exception_handler.ml b/compiler/tests/eliminate_exception_handler.ml index f17064006d..6b120f97c1 100644 --- a/compiler/tests/eliminate_exception_handler.ml +++ b/compiler/tests/eliminate_exception_handler.ml @@ -57,5 +57,5 @@ try raise Not_found with true) |} in - print_fun_decl program "some_name"; + print_fun_decl program (Some "some_name"); [%expect {| function some_name(param){try {throw Stdlib[8]}catch(_a_){return 0}} |}] diff --git a/compiler/tests/exceptions.ml b/compiler/tests/exceptions.ml new file mode 100644 index 0000000000..eb78d3a258 --- /dev/null +++ b/compiler/tests/exceptions.ml @@ -0,0 +1,58 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 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. + *) +open Util + +(* https://github.com/ocsigen/js_of_ocaml/issues/829 *) + +let%expect_test _ = + let compile ~debug s = + s + |> Filetype.ocaml_text_of_string + |> Filetype.write_ocaml + |> compile_ocaml_to_cmo ~debug + |> compile_cmo_to_javascript ~pretty:true ~sourcemap:debug + |> fst + |> parse_js + in + let program ~debug = + compile + ~debug + {| +let some_name () = raise (try try raise Not_found with x -> x with i -> i) +let prevent_inline = some_name + |} + in + print_fun_decl (program ~debug:true) None; + [%expect + {| + function some_name(param) + {try + {try {throw Stdlib[8]}catch(x){x = caml_wrap_exception(x);var i=x}} + catch(i$0){i$0 = caml_wrap_exception(i$0);var i=i$0} + throw i} |}]; + print_fun_decl (program ~debug:false) None; + [%expect + {| + function _a_(_b_) + {try + {try + {throw Stdlib[8]} + catch(_e_){_e_ = caml_wrap_exception(_e_);var _c_=_e_}} + catch(_d_){_d_ = caml_wrap_exception(_d_);throw _d_} + throw _c_} |}] diff --git a/compiler/tests/lazy.ml b/compiler/tests/lazy.ml index ea0d08d747..43aa2b7c75 100644 --- a/compiler/tests/lazy.ml +++ b/compiler/tests/lazy.ml @@ -39,7 +39,7 @@ let%expect_test "static eval of string get" = let _ = do_the_lazy_rec 8 |} in - print_fun_decl program "do_the_lazy_rec"; + print_fun_decl program (Some "do_the_lazy_rec"); [%expect {| function do_the_lazy_rec(n) diff --git a/compiler/tests/match_with_exn.ml b/compiler/tests/match_with_exn.ml index 887c942553..2120de541a 100644 --- a/compiler/tests/match_with_exn.ml +++ b/compiler/tests/match_with_exn.ml @@ -77,8 +77,8 @@ let fun2 () = |} in - print_fun_decl program "fun1"; - print_fun_decl program "fun2"; + print_fun_decl program (Some "fun1"); + print_fun_decl program (Some "fun2"); [%expect {| function fun1(param) diff --git a/compiler/tests/obj.ml b/compiler/tests/obj.ml index 0633a3865c..d91297a494 100644 --- a/compiler/tests/obj.ml +++ b/compiler/tests/obj.ml @@ -44,16 +44,16 @@ let%expect_test "static eval of string get" = let my_truncate t i = Obj.truncate (Obj.repr [t]) i |} in - print_fun_decl program "my_is_block"; - print_fun_decl program "my_is_int"; - print_fun_decl program "my_tag"; - print_fun_decl program "my_size"; - print_fun_decl program "my_field"; - print_fun_decl program "my_set_field"; - print_fun_decl program "my_set_tag"; - print_fun_decl program "my_new_block"; - print_fun_decl program "my_dup"; - print_fun_decl program "my_truncate"; + print_fun_decl program (Some "my_is_block"); + print_fun_decl program (Some "my_is_int"); + print_fun_decl program (Some "my_tag"); + print_fun_decl program (Some "my_size"); + print_fun_decl program (Some "my_field"); + print_fun_decl program (Some "my_set_field"); + print_fun_decl program (Some "my_set_tag"); + print_fun_decl program (Some "my_new_block"); + print_fun_decl program (Some "my_dup"); + print_fun_decl program (Some "my_truncate"); [%expect {| function my_is_block(x){return caml_call1(Stdlib_obj[1],x)} diff --git a/compiler/tests/util/util.ml b/compiler/tests/util/util.ml index 504c2da6b9..456656a784 100644 --- a/compiler/tests/util/util.ml +++ b/compiler/tests/util/util.ml @@ -187,13 +187,19 @@ let compile_bc_to_javascript ?flags ?(pretty = true) ?(sourcemap = true) file = let compile_cmo_to_javascript ?(pretty = true) ?(sourcemap = true) file = Filetype.path_of_cmo_file file |> compile_to_javascript ~pretty ~sourcemap -let compile_ocaml_to_cmo file = +let compile_ocaml_to_cmo ?(debug = true) file = let file = Filetype.path_of_ocaml_file file in let out_file = swap_extention file ~ext:"cmo" in let (stdout : string) = exec_to_string_exn ~env:[] - ~cmd:(Format.sprintf "%s -c -g %s -o %s" ocamlc file out_file) + ~cmd: + (Format.sprintf + "%s -c %s %s -o %s" + ocamlc + (if debug then "-g" else "") + file + out_file) in print_string stdout; Filetype.cmo_file_of_path out_file @@ -262,10 +268,15 @@ class find_function_declaration r n = method! source s = (match s with - | Function_declaration ((Jsoo.Javascript.S {name; _}, _, _, _) as fd) when name = n - -> - r := fd :: !r - | Function_declaration _ | Statement _ -> ()); + | Function_declaration fd -> + let record = + match fd, n with + | _, None -> true + | (Jsoo.Javascript.S {name; _}, _, _, _), Some n -> name = n + | _ -> false + in + if record then r := fd :: !r + | Statement _ -> ()); super#source s end diff --git a/compiler/tests/util/util.mli b/compiler/tests/util/util.mli index 766992001a..496cad7b93 100644 --- a/compiler/tests/util/util.mli +++ b/compiler/tests/util/util.mli @@ -23,7 +23,7 @@ module Filetype : Filetype_intf.S val parse_js : Filetype.js_file -> Javascript.program -val compile_ocaml_to_cmo : Filetype.ocaml_file -> Filetype.cmo_file +val compile_ocaml_to_cmo : ?debug:bool -> Filetype.ocaml_file -> Filetype.cmo_file val compile_ocaml_to_bc : Filetype.ocaml_file -> Filetype.bc_file @@ -48,6 +48,6 @@ val expression_to_string : ?compact:bool -> Javascript.expression -> string val print_var_decl : Javascript.program -> string -> unit -val print_fun_decl : Javascript.program -> string -> unit +val print_fun_decl : Javascript.program -> string option -> unit val compile_and_run : ?flags:string list -> string -> unit