From 42671a15c16f5f6b5e7b3c7e8762134339823535 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Nov 2022 12:10:31 +0100 Subject: [PATCH 1/6] Compiler: add test for loops --- compiler/tests-compiler/dune.inc | 13 ++ compiler/tests-compiler/loops.ml | 258 +++++++++++++++++++++++++++++++ 2 files changed, 271 insertions(+) create mode 100644 compiler/tests-compiler/loops.ml diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 0b1eb70e99..099dd08391 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -233,6 +233,19 @@ (preprocess (pps ppx_expect))) +(library + (name jsooexp_loops) + (modules loops) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (flags -allow-output-patterns) + (deps + (file ../../compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file ../../compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + (library (name jsooexp_macro) (modules macro) diff --git a/compiler/tests-compiler/loops.ml b/compiler/tests-compiler/loops.ml new file mode 100644 index 0000000000..bce8957514 --- /dev/null +++ b/compiler/tests-compiler/loops.ml @@ -0,0 +1,258 @@ +(* Js_of_ocaml tests + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2022 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 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 + +let%expect_test "rec-fun" = + let program = + compile_and_parse + {| + let rec fun_with_loop acc = function + | [] -> List.rev (List.rev (List.rev acc)) + | x :: xs -> fun_with_loop (x :: acc) xs +|} + in + print_fun_decl program (Some "fun_with_loop"); + [%expect + {| + function fun_with_loop(acc,param) + {var acc$0=acc,param$0=param; + for(;;) + {if(param$0) + {var + param$1=param$0[2], + x=param$0[1], + acc$1=[0,x,acc$0], + acc$0=acc$1, + param$0=param$1; + continue} + var + _a_=caml_call1(Stdlib_List[9],acc$0), + _b_=caml_call1(Stdlib_List[9],_a_); + return caml_call1(Stdlib_List[9],_b_)}} |}] + +let%expect_test "rec-fun-2" = + let program = + compile_and_parse + {| +let rec fun_with_loop acc = function + | [] -> List.rev (List.rev (List.rev acc)) + | [ 1 ] -> + let a = ref acc in + for i = 0 to 10 do + a := 1 :: !a + done; + !a + | x :: xs -> + let a = ref acc in + for i = 0 to 10 do + a := 1 :: !a + done; + fun_with_loop (x :: !a) xs + |} + in + print_fun_decl program (Some "fun_with_loop"); + [%expect + {| + function fun_with_loop(acc,param) + {var acc$0=acc,param$0=param; + a: + for(;;) + {if(param$0) + {var _a_=param$0[1]; + if(1 === _a_ && ! param$0[2]) + {var a$0=[0,acc$0],i$0=0; + for(;;) + {a$0[1] = [0,1,a$0[1]]; + var _c_=i$0 + 1 | 0; + if(10 !== i$0){var i$0=_c_;continue} + return a$0[1]}} + var xs=param$0[2],a=[0,acc$0],i=0; + for(;;) + {a[1] = [0,1,a[1]]; + var _b_=i + 1 | 0; + if(10 !== i){var i=_b_;continue} + var acc$1=[0,_a_,a[1]],acc$0=acc$1,param$0=xs; + continue a}} + var + _d_=caml_call1(Stdlib_List[9],acc$0), + _e_=caml_call1(Stdlib_List[9],_d_); + return caml_call1(Stdlib_List[9],_e_)}} + |}] + +let%expect_test "for-for-while" = + let program = + compile_and_parse + {| +let id = ref 0 +let for_for_while () = + for k = 1 to 10 do + for j = 1 to 10 do + while k * j < 10 do + incr id + done + done + done + |} + in + print_fun_decl program (Some "for_for_while"); + [%expect + {| + function for_for_while(param) + {var k=1; + a: + for(;;) + {var j=1; + b: + for(;;) + for(;;) + {if(10 <= runtime.caml_mul(k,j)) + {var _b_=j + 1 | 0; + if(10 !== j){var j=_b_;continue b} + var _a_=k + 1 | 0; + if(10 !== k){var k=_a_;continue a} + return 0} + id[1]++; + continue}}} |}] + +let%expect_test "for-for-while-try" = + let program = + compile_and_parse + {| +let id = ref 0 +let for_for_while () = + for k = 1 to 10 do + for j = 1 to 10 do + while k / j < 10 do + ignore (try k / j with _ -> raise Not_found); + incr id + done + done + done + |} + in + print_fun_decl program (Some "for_for_while"); + [%expect + {| + function for_for_while(param) + {var k=1; + a: + for(;;) + {var j=1; + b: + for(;;) + for(;;) + {if(10 <= caml_div(k,j)) + {var _b_=j + 1 | 0; + if(10 !== j){var j=_b_;continue b} + var _a_=k + 1 | 0; + if(10 !== k){var k=_a_;continue a} + return 0} + try {caml_div(k,j)}catch(_c_){throw Stdlib[8]} + id[1]++; + continue}}} |}] + +let%expect_test "loop seq.ml" = + let program = + compile_and_parse + {| + + type +'a node = + | Nil + | Cons of 'a * 'a t + +and 'a t = unit -> 'a node + +let rec equal eq xs ys = + match xs(), ys() with + | Nil, Nil -> + true + | Cons (x, xs), Cons (y, ys) -> + equal eq xs ys + | Nil, Cons (_, _) + | Cons (_, _), Nil -> + false + |} + in + print_fun_decl program (Some "equal"); + [%expect + {| + function equal(eq,xs,ys) + {var xs$0=xs,ys$0=ys; + for(;;) + {var match=caml_call1(xs$0,0),match$0=caml_call1(ys$0,0); + if(match) + {if(match$0) + {var ys$1=match$0[2],xs$1=match[2],xs$0=xs$1,ys$0=ys$1;continue}} + else + if(! match$0)return 1; + return 0}} |}] + +let%expect_test "try-catch inside loop" = + let program = + compile_and_parse + {| +let f t x = + let rec loop t x = + match Hashtbl.find t x with + | [ y ] -> y = x + 1 || loop t y + | _ -> false + | exception Exit -> false + in + let other t x = + match Hashtbl.find t x with + | exception Not_found -> -1 + | [ x ] -> if loop t x then 1 else 2 + | _ -> -2 + in + other t x + |} + in + print_fun_decl program (Some "f"); + [%expect + {| + function f(t,x) + {function other(t,x$0) + {try + {var val$0=caml_call2(Stdlib_Hashtbl[6],t,x$0)} + catch(_e_) + {_e_ = caml_wrap_exception(_e_); + if(_e_ === Stdlib[8])return - 1; + throw _e_} + if(val$0 && ! val$0[2]) + {var x$1=val$0[1],x=x$1; + for(;;) + {try + {var switch$0=0,val=caml_call2(Stdlib_Hashtbl[6],t,x);switch$0 = 1} + catch(_d_) + {_d_ = caml_wrap_exception(_d_); + if(_d_ !== Stdlib[3])throw _d_; + var _b_=0,_c_=_d_} + if(switch$0) + {var switch$1=0; + if(val && ! val[2]) + {var y=val[1],_a_=y === (x + 1 | 0)?1:0; + if(! _a_){var x=y;continue} + var _b_=_a_} + else + switch$1 = 1; + if(switch$1)var _b_=0} + return _b_?1:2}} + return - 2} + return other(t,x)} |}] From 73cfa8ea4a69e894918abf0a7c60c70d6bdc3d1b Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sun, 20 Nov 2022 14:41:55 +0100 Subject: [PATCH 2/6] Compiler: small refactoring --- compiler/bin-js_of_ocaml/compile.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 7d41658acf..39c75fcff2 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -274,11 +274,11 @@ let run List.iter cma.lib_units ~f:(fun cmo -> let output_file = match output_file with - | `Stdout, false -> `Name (gen_unit_filename "./" cmo) - | `Name x, false -> `Name (gen_unit_filename (Filename.dirname x) cmo) + | `Stdout, false -> gen_unit_filename "./" cmo + | `Name x, false -> gen_unit_filename (Filename.dirname x) cmo | `Name x, true when String.length x > 0 && Char.equal x.[String.length x - 1] '/' -> - `Name (gen_unit_filename x cmo) + gen_unit_filename x cmo | `Stdout, true | `Name _, true -> failwith "use [-o dirname/] or remove [--keep-unit-names]" in @@ -293,7 +293,7 @@ let run in if times () then Format.eprintf " parsing: %a (%s)@." Timer.print t1 cmo.cu_name; - output_partial code output_file) + output_partial code (`Name output_file)) | `Cma cma -> let t1 = Timer.make () in let code = From abd05e8d84ce13c244cc934398266ca760854c71 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 21 Nov 2022 11:29:00 +0100 Subject: [PATCH 3/6] Compiler: more checks --- compiler/lib/generate.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 8f152f1767..efdd87b3e7 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1385,6 +1385,12 @@ and compile_block st queue (pc : Addr.t) frontier interm = (* Remove limit *) if pc < 0 then List.iter succs ~f:(fun pc -> unprotect_preds st pc); let succs = List.map succs ~f:(fun pc -> pc, dominance_frontier st pc) in + if pc < 0 + && List.for_all succs ~f:(fun (pc, front) -> + Addr.Set.cardinal front = 1 && Addr.Set.choose front = pc) + then ( + Format.eprintf "Something is wrong. Stopping now to prevent infinite loop.@."; + assert false); let grey = List.fold_right ~f:(fun (_, frontier) grey -> Addr.Set.union frontier grey) From 5814a3a7b1365bc51c70b325e03320ce23969d35 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Nov 2022 15:49:44 +0100 Subject: [PATCH 4/6] Compiler: some doc for generate.ml --- compiler/lib/generate.ml | 113 +++++++++++++++++++-------------------- 1 file changed, 55 insertions(+), 58 deletions(-) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index efdd87b3e7..99bc4396c1 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1397,6 +1397,7 @@ and compile_block st queue (pc : Addr.t) frontier interm = succs ~init:Addr.Set.empty in + (* TODO: Check that we are inside the [frontier] *) let new_frontier = resolve_nodes interm grey in let block = Addr.Map.find pc st.blocks in let seq, queue = @@ -1408,38 +1409,33 @@ and compile_block st queue (pc : Addr.t) frontier interm = match block.branch with | Code.Pushtrap ((pc1, args1), x, (pc2, args2), pc3s) -> (* FIX: document this *) - let pc2s = resolve_nodes interm (dominance_frontier st pc2) in - let pc3s = - Addr.Set.fold - (fun pc3 acc -> - (* We need to make sure that pc3 is live (indeed, the - continuation may have been optimized away by inlining) *) - if Hashtbl.mem st.succs pc3 - then - (* no need to limit body for simple flow with no instruction. - eg return and branch *) - let rec limit pc = - if Addr.Set.mem pc pc2s - then false - else - let block = Addr.Map.find pc st.blocks in - (not (List.is_empty block.body)) - || - match block.branch with - | Return _ -> false - | Poptrap ((pc', _), _) | Branch (pc', _) -> limit pc' - | _ -> true - in - if limit pc3 then Addr.Set.add pc3 acc else acc - else acc) - pc3s - Addr.Set.empty + let exn_frontier = dominance_frontier st pc2 in + (* We need to make sure that pc3 is live (indeed, the + continuation may have been optimized away by inlining) *) + let pc3s = Addr.Set.filter (fun pc -> Hashtbl.mem st.succs pc) pc3s in + (* no need to limit body for simple flow with no + instruction. eg return and branch *) + let rec limit pc = + if Addr.Set.mem pc exn_frontier + then false + else + match Addr.Map.find pc st.blocks with + | { body = []; branch = Return _; _ } -> false + | { body = []; branch = Poptrap ((pc', _), _); _ } + | { body = []; branch = Branch (pc', _); _ } -> limit pc' + | _ -> true + in + let handler_frontier = Addr.Set.filter limit pc3s in + (* TODO: Check that we are inside the [frontier/new_frontier] *) + let handler_frontier = + resolve_nodes interm (Addr.Set.union exn_frontier handler_frontier) + in + Addr.Set.iter (incr_preds st) handler_frontier; + let prefix, handler_frontier_cont, handler_interm = + colapse_frontier st handler_frontier interm in - let grey = Addr.Set.union pc2s pc3s in - Addr.Set.iter (incr_preds st) grey; - let prefix, grey', new_interm = colapse_frontier st grey interm in - assert (Addr.Set.cardinal grey' <= 1); - let inner_frontier = Addr.Set.union new_frontier grey' in + assert (Addr.Set.cardinal handler_frontier_cont <= 1); + let try_catch_frontier = Addr.Set.union new_frontier handler_frontier_cont in if debug () then Format.eprintf "@[<2>try {@,"; let body = prefix @@ -1449,8 +1445,8 @@ and compile_block st queue (pc : Addr.t) frontier interm = (pc1, args1) None Addr.Set.empty - inner_frontier - new_interm + try_catch_frontier + handler_interm in if debug () then Format.eprintf "} catch {@,"; let x = @@ -1458,14 +1454,14 @@ and compile_block st queue (pc : Addr.t) frontier interm = let m = Subst.build_mapping args2 block2.params in try Var.Map.find x m with Not_found -> x in - let handler = compile_block st [] pc2 inner_frontier new_interm in + let handler = compile_block st [] pc2 try_catch_frontier handler_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 = + Addr.Set.iter (decr_preds st) handler_frontier; + + let exn_escape = + match Addr.Set.choose handler_frontier_cont with + | exception Not_found -> None + | pc -> let x' = Var.fork x in let found = ref false in let map_var y = @@ -1488,11 +1484,14 @@ and compile_block st queue (pc : Addr.t) frontier interm = 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 after = + match Addr.Set.choose handler_frontier_cont with + | exception Not_found -> [] + | pc -> + if Addr.Set.mem pc frontier + then [] + else compile_block st [] pc frontier interm in let handler = if st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap () @@ -1524,11 +1523,11 @@ and compile_block st queue (pc : Addr.t) frontier interm = (( J.Try_statement (body, Some (J.V x, handler), None) , source_location st.ctx pc ) :: after) - | _ -> - let prefix, new_frontier, new_interm = + | _ -> ( + let prefix, frontier_cont, new_interm = colapse_frontier st new_frontier interm in - assert (Addr.Set.cardinal new_frontier <= 1); + assert (Addr.Set.cardinal frontier_cont <= 1); (* Beware evaluation order! *) let cond = compile_conditional @@ -1538,20 +1537,19 @@ and compile_block st queue (pc : Addr.t) frontier interm = block.branch block.handler backs - new_frontier + frontier_cont new_interm succs in prefix @ cond @ - if Addr.Set.cardinal new_frontier = 0 - then [] - else - let pc = Addr.Set.choose new_frontier in - if Addr.Set.mem pc frontier - then [] - else compile_block st [] pc frontier interm + match Addr.Set.choose frontier_cont with + | exception Not_found -> [] + | pc -> + if Addr.Set.mem pc frontier + then [] + else compile_block st [] pc frontier interm) in if Addr.Set.mem pc st.loops then @@ -1570,8 +1568,7 @@ and compile_block st queue (pc : Addr.t) frontier interm = , Js_simpl.block (if Addr.Set.cardinal frontier > 0 then ( - if debug () - then Format.eprintf "@ break (%d); }@]" (Addr.Set.choose new_frontier); + if debug () then Format.eprintf "@ break; }@]"; body @ [ J.Break_statement None, J.N ]) else ( if debug () then Format.eprintf "}@]"; From a2f68d960155b8c8dea734ebff85dc7a2830a7c3 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 21 Nov 2022 11:21:36 +0100 Subject: [PATCH 5/6] Compiler: refactor compile_block --- compiler/lib/generate.ml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 99bc4396c1..a28e68a5dd 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1437,6 +1437,7 @@ and compile_block st queue (pc : Addr.t) frontier interm = assert (Addr.Set.cardinal handler_frontier_cont <= 1); let try_catch_frontier = Addr.Set.union new_frontier handler_frontier_cont in if debug () then Format.eprintf "@[<2>try {@,"; + if Addr.Map.mem pc1 handler_interm then decr_preds st pc1; let body = prefix @ compile_branch @@ -1444,7 +1445,7 @@ and compile_block st queue (pc : Addr.t) frontier interm = [] (pc1, args1) None - Addr.Set.empty + backs try_catch_frontier handler_interm in @@ -1454,7 +1455,10 @@ and compile_block st queue (pc : Addr.t) frontier interm = let m = Subst.build_mapping args2 block2.params in try Var.Map.find x m with Not_found -> x in - let handler = compile_block st [] pc2 try_catch_frontier handler_interm in + if Addr.Map.mem pc2 handler_interm then decr_preds st pc2; + let handler = + compile_branch st [] (pc2, args2) None backs try_catch_frontier handler_interm + in if debug () then Format.eprintf "}@]@ "; Addr.Set.iter (decr_preds st) handler_frontier; @@ -1528,6 +1532,8 @@ and compile_block st queue (pc : Addr.t) frontier interm = colapse_frontier st new_frontier interm in assert (Addr.Set.cardinal frontier_cont <= 1); + List.iter succs ~f:(fun (pc, _) -> + if Addr.Map.mem pc new_interm then decr_preds st pc); (* Beware evaluation order! *) let cond = compile_conditional @@ -1616,7 +1622,7 @@ and colapse_frontier st new_frontier interm = of the frontier. *) Addr.Set.iter (fun pc -> incr_preds st pc) new_frontier; (* Put a limit: we are going to remove other branches - to the members of the frontier (in compile_conditional), + to the members of the frontier (in compile_block), but they should remain in the frontier. *) Addr.Set.iter (fun pc -> protect_preds st pc) new_frontier; Hashtbl.add st.succs idx (Addr.Set.elements new_frontier); @@ -1695,7 +1701,6 @@ and compile_decision_tree st _queue handler backs frontier interm succs loc cx d binds @ snd (loop cx dtree) and compile_conditional st queue pc last handler backs frontier interm succs = - List.iter succs ~f:(fun (pc, _) -> if Addr.Map.mem pc interm then decr_preds st pc); (if debug () then match last with From 85eb7fe739ee7a6e12d071c89157b55d6041b739 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 21 Nov 2022 11:50:15 +0100 Subject: [PATCH 6/6] Compiler: generate: split loop logic out --- compiler/lib/generate.ml | 424 +++++++++++++++++++-------------------- 1 file changed, 203 insertions(+), 221 deletions(-) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index a28e68a5dd..cbd4a8afc2 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1360,231 +1360,213 @@ and compile_block st queue (pc : Addr.t) frontier interm = if (not (List.is_empty queue)) && (Addr.Set.mem pc st.loops || not (Config.Flag.inline ())) then flush_all queue (compile_block st [] pc frontier interm) - else ( - if pc >= 0 - then ( - if Addr.Set.mem pc st.visited_blocks - then ( - Format.eprintf "Trying to compile a block twice !!!! %d@." pc; - assert false); - st.visited_blocks <- Addr.Set.add pc st.visited_blocks); - if debug () - then ( - if Addr.Set.mem pc st.loops then Format.eprintf "@[<2>for(;;){@,"; - Format.eprintf "block %d;@ @?" pc); - (if Addr.Set.mem pc st.loops - then - let lab = - match st.loop_stack with - | (_, (l, _)) :: _ -> J.Label.succ l - | [] -> J.Label.zero - in - st.loop_stack <- (pc, (lab, ref false)) :: st.loop_stack); - let succs = Hashtbl.find st.succs pc in - let backs = Hashtbl.find st.backs pc in - (* Remove limit *) - if pc < 0 then List.iter succs ~f:(fun pc -> unprotect_preds st pc); - let succs = List.map succs ~f:(fun pc -> pc, dominance_frontier st pc) in - if pc < 0 - && List.for_all succs ~f:(fun (pc, front) -> - Addr.Set.cardinal front = 1 && Addr.Set.choose front = pc) + else + match Addr.Set.mem pc st.loops with + | false -> compile_block_no_loop st queue pc frontier interm + | true -> ( + if debug () then Format.eprintf "@[<2>for(;;){@,"; + let lab = + match st.loop_stack with + | (_, (l, _)) :: _ -> J.Label.succ l + | [] -> J.Label.zero + in + st.loop_stack <- (pc, (lab, ref false)) :: st.loop_stack; + let body = compile_block_no_loop st queue pc frontier interm in + let for_loop = + ( J.For_statement + ( J.Left None + , None + , None + , Js_simpl.block + (if Addr.Set.cardinal frontier > 0 + then ( + if debug () then Format.eprintf "@ break; }@]"; + body @ [ J.Break_statement None, J.N ]) + else ( + if debug () then Format.eprintf "}@]"; + body)) ) + , source_location st.ctx pc ) + in + let label = + match st.loop_stack with + | (_, (l, used)) :: r -> + st.loop_stack <- r; + if !used then Some l else None + | [] -> assert false + in + match label with + | None -> [ for_loop ] + | Some label -> [ J.Labelled_statement (label, for_loop), J.N ]) + +and compile_block_no_loop st queue (pc : Addr.t) frontier interm = + if pc >= 0 + then ( + if Addr.Set.mem pc st.visited_blocks then ( - Format.eprintf "Something is wrong. Stopping now to prevent infinite loop.@."; + Format.eprintf "Trying to compile a block twice !!!! %d@." pc; assert false); - let grey = - List.fold_right - ~f:(fun (_, frontier) grey -> Addr.Set.union frontier grey) - succs - ~init:Addr.Set.empty - in - (* TODO: Check that we are inside the [frontier] *) - let new_frontier = resolve_nodes interm grey in - let block = Addr.Map.find pc st.blocks in - let seq, queue = - translate_instrs st.ctx queue (source_location st.ctx pc) block.body - in - let body = - seq - @ - match block.branch with - | Code.Pushtrap ((pc1, args1), x, (pc2, args2), pc3s) -> - (* FIX: document this *) - let exn_frontier = dominance_frontier st pc2 in - (* We need to make sure that pc3 is live (indeed, the - continuation may have been optimized away by inlining) *) - let pc3s = Addr.Set.filter (fun pc -> Hashtbl.mem st.succs pc) pc3s in - (* no need to limit body for simple flow with no - instruction. eg return and branch *) - let rec limit pc = - if Addr.Set.mem pc exn_frontier - then false - else - match Addr.Map.find pc st.blocks with - | { body = []; branch = Return _; _ } -> false - | { body = []; branch = Poptrap ((pc', _), _); _ } - | { body = []; branch = Branch (pc', _); _ } -> limit pc' - | _ -> true - in - let handler_frontier = Addr.Set.filter limit pc3s in - (* TODO: Check that we are inside the [frontier/new_frontier] *) - let handler_frontier = - resolve_nodes interm (Addr.Set.union exn_frontier handler_frontier) - in - Addr.Set.iter (incr_preds st) handler_frontier; - let prefix, handler_frontier_cont, handler_interm = - colapse_frontier st handler_frontier interm - in - assert (Addr.Set.cardinal handler_frontier_cont <= 1); - let try_catch_frontier = Addr.Set.union new_frontier handler_frontier_cont in - if debug () then Format.eprintf "@[<2>try {@,"; - if Addr.Map.mem pc1 handler_interm then decr_preds st pc1; - let body = - prefix - @ compile_branch - st - [] - (pc1, args1) - None - backs - try_catch_frontier - handler_interm - in - if debug () then Format.eprintf "} catch {@,"; - let x = - let block2 = Addr.Map.find pc2 st.blocks in - let m = Subst.build_mapping args2 block2.params in - try Var.Map.find x m with Not_found -> x - in - if Addr.Map.mem pc2 handler_interm then decr_preds st pc2; - let handler = - compile_branch st [] (pc2, args2) None backs try_catch_frontier handler_interm - in - if debug () then Format.eprintf "}@]@ "; - Addr.Set.iter (decr_preds st) handler_frontier; - - let exn_escape = - match Addr.Set.choose handler_frontier_cont with - | exception Not_found -> None - | pc -> - 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 - { fold = 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 - let after = - match Addr.Set.choose handler_frontier_cont with - | exception Not_found -> [] - | pc -> - if Addr.Set.mem pc frontier - then [] - else compile_block st [] pc frontier interm - in - let handler = - if st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap () - then - ( J.Expression_statement - (J.EBin - ( J.Eq - , J.EVar (J.V x) - , ecall - (Share.get_prim - (runtime_fun st.ctx) - "caml_wrap_exception" - st.ctx.Ctx.share) - [ J.EVar (J.V x) ] - J.N )) - , J.N ) - :: handler - else handler - in - 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 ) - :: after) - | _ -> ( - let prefix, frontier_cont, new_interm = - colapse_frontier st new_frontier interm - in - assert (Addr.Set.cardinal frontier_cont <= 1); - List.iter succs ~f:(fun (pc, _) -> - if Addr.Map.mem pc new_interm then decr_preds st pc); - (* Beware evaluation order! *) - let cond = - compile_conditional - st - queue - pc - block.branch - block.handler - backs - frontier_cont - new_interm - succs - in - prefix - @ cond - @ - match Addr.Set.choose frontier_cont with - | exception Not_found -> [] - | pc -> - if Addr.Set.mem pc frontier - then [] - else compile_block st [] pc frontier interm) - in - if Addr.Set.mem pc st.loops - then - let label = - match st.loop_stack with - | (_, (l, used)) :: r -> - st.loop_stack <- r; - if !used then Some l else None - | [] -> assert false + st.visited_blocks <- Addr.Set.add pc st.visited_blocks); + if debug () then Format.eprintf "block %d;@ @?" pc; + let succs = Hashtbl.find st.succs pc in + let backs = Hashtbl.find st.backs pc in + (* Remove limit *) + if pc < 0 then List.iter succs ~f:(fun pc -> unprotect_preds st pc); + let succs = List.map succs ~f:(fun pc -> pc, dominance_frontier st pc) in + if pc < 0 + && List.for_all succs ~f:(fun (pc, front) -> + Addr.Set.cardinal front = 1 && Addr.Set.choose front = pc) + then ( + Format.eprintf "Something is wrong. Stopping now to prevent infinite loop.@."; + assert false); + let grey = + List.fold_right + ~f:(fun (_, frontier) grey -> Addr.Set.union frontier grey) + succs + ~init:Addr.Set.empty + in + (* TODO: Check that we are inside the [frontier] *) + let new_frontier = resolve_nodes interm grey in + let block = Addr.Map.find pc st.blocks in + let seq, queue = translate_instrs st.ctx queue (source_location st.ctx pc) block.body in + seq + @ + match block.branch with + | Code.Pushtrap ((pc1, args1), x, (pc2, args2), pc3s) -> + (* FIX: document this *) + let exn_frontier = dominance_frontier st pc2 in + (* We need to make sure that pc3 is live (indeed, the + continuation may have been optimized away by inlining) *) + let pc3s = Addr.Set.filter (fun pc -> Hashtbl.mem st.succs pc) pc3s in + (* no need to limit body for simple flow with no + instruction. eg return and branch *) + let rec limit pc = + if Addr.Set.mem pc exn_frontier + then false + else + match Addr.Map.find pc st.blocks with + | { body = []; branch = Return _; _ } -> false + | { body = []; branch = Poptrap ((pc', _), _); _ } + | { body = []; branch = Branch (pc', _); _ } -> limit pc' + | _ -> true in - let st = - ( J.For_statement - ( J.Left None - , None - , None - , Js_simpl.block - (if Addr.Set.cardinal frontier > 0 - then ( - if debug () then Format.eprintf "@ break; }@]"; - body @ [ J.Break_statement None, J.N ]) - else ( - if debug () then Format.eprintf "}@]"; - body)) ) - , source_location st.ctx pc ) + let handler_frontier = Addr.Set.filter limit pc3s in + (* TODO: Check that we are inside the [frontier/new_frontier] *) + let handler_frontier = + resolve_nodes interm (Addr.Set.union exn_frontier handler_frontier) + in + Addr.Set.iter (incr_preds st) handler_frontier; + let prefix, handler_frontier_cont, handler_interm = + colapse_frontier st handler_frontier interm + in + assert (Addr.Set.cardinal handler_frontier_cont <= 1); + let try_catch_frontier = Addr.Set.union new_frontier handler_frontier_cont in + if debug () then Format.eprintf "@[<2>try {@,"; + if Addr.Map.mem pc1 handler_interm then decr_preds st pc1; + let body = + prefix + @ compile_branch st [] (pc1, args1) None backs try_catch_frontier handler_interm in - match label with - | None -> [ st ] - | Some label -> [ J.Labelled_statement (label, st), J.N ] - else body) + if debug () then Format.eprintf "} catch {@,"; + let x = + let block2 = Addr.Map.find pc2 st.blocks in + let m = Subst.build_mapping args2 block2.params in + try Var.Map.find x m with Not_found -> x + in + if Addr.Map.mem pc2 handler_interm then decr_preds st pc2; + let handler = + compile_branch st [] (pc2, args2) None backs try_catch_frontier handler_interm + in + if debug () then Format.eprintf "}@]@ "; + Addr.Set.iter (decr_preds st) handler_frontier; + + let exn_escape = + match Addr.Set.choose handler_frontier_cont with + | exception Not_found -> None + | pc -> + 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 + { fold = 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 + let after = + match Addr.Set.choose handler_frontier_cont with + | exception Not_found -> [] + | pc -> + if Addr.Set.mem pc frontier + then [] + else compile_block st [] pc frontier interm + in + let handler = + if st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap () + then + ( J.Expression_statement + (J.EBin + ( J.Eq + , J.EVar (J.V x) + , ecall + (Share.get_prim + (runtime_fun st.ctx) + "caml_wrap_exception" + st.ctx.Ctx.share) + [ J.EVar (J.V x) ] + J.N )) + , J.N ) + :: handler + else handler + in + 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) + :: after) + | _ -> ( + let prefix, frontier_cont, new_interm = colapse_frontier st new_frontier interm in + assert (Addr.Set.cardinal frontier_cont <= 1); + List.iter succs ~f:(fun (pc, _) -> + if Addr.Map.mem pc new_interm then decr_preds st pc); + (* Beware evaluation order! *) + let cond = + compile_conditional + st + queue + pc + block.branch + block.handler + backs + frontier_cont + new_interm + succs + in + prefix + @ cond + @ + match Addr.Set.choose frontier_cont with + | exception Not_found -> [] + | pc -> + if Addr.Set.mem pc frontier then [] else compile_block st [] pc frontier interm) and colapse_frontier st new_frontier interm = if Addr.Set.cardinal new_frontier > 1