diff --git a/CHANGES.md b/CHANGES.md index 283731366b..d85b4a3e8a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -29,6 +29,7 @@ * Compiler: improve debug/sourcemap location of closures (#1947) * Compiler: improve tailcall optimization (#1943) * Runtime: use Dataview to convert between floats and bit representation +* Compiler: speed-up compilation by improving the scheduling of optimization passes (#1962) ## Bug fixes * Compiler: fix stack overflow issues with double translation (#1869) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index d8ba2bea09..f26dcc36c2 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -835,11 +835,35 @@ let check_updates ~name p1 p2 ~updates = print_diff p1 p2; assert false +let cont_equal (pc, args) (pc', args') = pc = pc' && List.equal ~eq:Var.equal args args' + +let cont_compare (pc, args) (pc', args') = + let c = compare pc pc' in + if c <> 0 then c else List.compare ~cmp:Var.compare args args' + let with_invariant = Debug.find "invariant" let check_defs = false -let invariant { blocks; start; _ } = +let used_blocks p = + let visited = BitSet.create' p.free_pc in + let rec mark_used pc = + if not (BitSet.mem visited pc) + then ( + BitSet.set visited pc; + let block = Addr.Map.find pc p.blocks in + List.iter + ~f:(fun i -> + match i with + | Let (_, Closure (_, (pc', _), _)) -> mark_used pc' + | _ -> ()) + block.body; + fold_children p.blocks pc (fun pc' () -> mark_used pc') ()) + in + mark_used p.start; + visited + +let invariant ({ blocks; start; _ } as p) = if with_invariant () then ( assert (Addr.Map.mem start blocks); @@ -889,6 +913,7 @@ let invariant { blocks; start; _ } = | Stop -> () | Branch cont -> check_cont cont | Cond (_x, cont1, cont2) -> + assert (not (cont_equal cont1 cont2)); check_cont cont1; check_cont cont2 | Switch (_x, a1) -> Array.iteri a1 ~f:(fun _ cont -> check_cont cont) @@ -897,16 +922,12 @@ let invariant { blocks; start; _ } = check_cont cont2 | Poptrap cont -> check_cont cont in + let visited = used_blocks p in Addr.Map.iter - (fun _pc block -> + (fun pc block -> + assert (BitSet.mem visited pc); List.iter block.params ~f:define; List.iter block.body ~f:check_instr; check_events block.body; check_last block.branch) blocks) - -let cont_equal (pc, args) (pc', args') = pc = pc' && List.equal ~eq:Var.equal args args' - -let cont_compare (pc, args) (pc', args') = - let c = compare pc pc' in - if c <> 0 then c else List.compare ~cmp:Var.compare args args' diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 99a33b38ad..3648b6f4bb 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -311,6 +311,8 @@ val traverse : val preorder_traverse : fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c +val used_blocks : program -> BitSet.t + val prepend : program -> instr list -> program val empty : program diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml index 20b3c3cc60..c4d5cd9bde 100644 --- a/compiler/lib/deadcode.ml +++ b/compiler/lib/deadcode.ml @@ -49,6 +49,7 @@ type t = ; mutable deleted_instrs : int ; mutable deleted_blocks : int ; mutable deleted_params : int + ; mutable block_shortcut : int } (****) @@ -185,6 +186,30 @@ let annot st pc xi = (****) +let remove_unused_blocks' p = + let count = ref 0 in + let used = Code.used_blocks p in + let blocks = + Addr.Map.filter + (fun pc _ -> + let b = BitSet.mem used pc in + if not b then incr count; + b) + p.blocks + in + { p with blocks }, !count + +let remove_unused_blocks p = + let previous_p = p in + let t = Timer.make () in + let p, count = remove_unused_blocks' p in + if times () then Format.eprintf " dead block: %a@." Timer.print t; + if stats () then Format.eprintf "Stats - dead block: deleted %d@." count; + if debug_stats () then Code.check_updates ~name:"dead block" previous_p p ~updates:count; + p + +(****) + let rec add_arg_dep defs params args = match params, args with | x :: params, y :: args -> @@ -194,19 +219,15 @@ let rec add_arg_dep defs params args = | _ -> assert false let add_cont_dep blocks defs (pc, args) = - match try Some (Addr.Map.find pc blocks) with Not_found -> None with - | Some block -> add_arg_dep defs block.params args - | None -> () (* Dead continuation *) + let block = Addr.Map.find pc blocks in + add_arg_dep defs block.params args let empty_body b = match b with | [] | [ Event _ ] -> true | _ -> false -let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = - let previous_p = p in - let t = Timer.make () in - let count = ref 0 in +let remove_empty_blocks st (p : Code.program) : Code.program = let shortcuts = Hashtbl.create 16 in let rec resolve_rec visited ((pc, args) as cont) = if Addr.Set.mem pc visited @@ -214,13 +235,16 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = else match Hashtbl.find_opt shortcuts pc with | Some (params, cont) -> - incr count; let pc', args' = resolve_rec (Addr.Set.add pc visited) cont in let s = Subst.from_map (Subst.build_mapping params args) in pc', List.map ~f:s args' | None -> cont in - let resolve cont = resolve_rec Addr.Set.empty cont in + let resolve cont = + let cont' = resolve_rec Addr.Set.empty cont in + if not (Code.cont_equal cont cont') then st.block_shortcut <- st.block_shortcut + 1; + cont' + in Addr.Map.iter (fun pc block -> match block with @@ -235,7 +259,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = used as argument to the continuation *) if List.for_all - ~f:(fun x -> live_vars.(Var.idx x) = 1 && Var.Set.mem x args) + ~f:(fun x -> st.live.(Var.idx x) = 1 && Var.Set.mem x args) params then Hashtbl.add shortcuts pc (params, cont) | _ -> ()) @@ -248,7 +272,12 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = (let branch = block.branch in match branch with | Branch cont -> Branch (resolve cont) - | Cond (x, cont1, cont2) -> Cond (x, resolve cont1, resolve cont2) + | Cond (x, cont1, cont2) -> + let cont1' = resolve cont1 in + let cont2' = resolve cont2 in + if Code.cont_equal cont1' cont2' + then Branch cont1' + else Cond (x, cont1', cont2') | Switch (x, a1) -> Switch (x, Array.map ~f:resolve a1) | Pushtrap (cont1, x, cont2) -> Pushtrap (resolve cont1, x, resolve cont2) | Poptrap cont -> Poptrap (resolve cont) @@ -256,12 +285,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = }) p.blocks in - let p = { p with blocks } in - if times () then Format.eprintf " dead code elim. empty blocks: %a@." Timer.print t; - if stats () then Format.eprintf "Stats - dead code empty blocks: %d@." !count; - if debug_stats () - then Code.check_updates ~name:"emptyblock" previous_p p ~updates:!count; - p + { p with blocks } let f ({ blocks; _ } as p : Code.program) = let previous_p = p in @@ -299,52 +323,60 @@ let f ({ blocks; _ } as p : Code.program) = ; deleted_instrs = 0 ; deleted_blocks = 0 ; deleted_params = 0 + ; block_shortcut = 0 } in mark_reachable st p.start; if debug () then Print.program Format.err_formatter (fun pc xi -> annot st pc xi) p; - let all_blocks = blocks in - let blocks = - Addr.Map.filter_map - (fun pc block -> - if not (BitSet.mem st.reachable_blocks pc) - then ( - st.deleted_blocks <- st.deleted_blocks + 1; - None) - else - Some - { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0) - ; body = - List.fold_left block.body ~init:[] ~f:(fun acc i -> - match i, acc with - | Event _, Event _ :: prev -> - (* Avoid consecutive events (keep just the last one) *) - i :: prev - | _ -> - if live_instr st i - then filter_closure all_blocks st i :: acc - else ( - st.deleted_instrs <- st.deleted_instrs + 1; - acc)) - |> List.rev - ; branch = filter_live_last all_blocks st block.branch - }) - blocks + let p = + let all_blocks = blocks in + let blocks = + Addr.Map.filter_map + (fun pc block -> + if not (BitSet.mem st.reachable_blocks pc) + then ( + st.deleted_blocks <- st.deleted_blocks + 1; + None) + else + Some + { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0) + ; body = + List.fold_left block.body ~init:[] ~f:(fun acc i -> + match i, acc with + | Event _, Event _ :: prev -> + (* Avoid consecutive events (keep just the last one) *) + i :: prev + | _ -> + if live_instr st i + then filter_closure all_blocks st i :: acc + else ( + st.deleted_instrs <- st.deleted_instrs + 1; + acc)) + |> List.rev + ; branch = filter_live_last all_blocks st block.branch + }) + blocks + in + { p with blocks } in - let p = { p with blocks } in + let p = remove_empty_blocks st p in if times () then Format.eprintf " dead code elim.: %a@." Timer.print t; if stats () then Format.eprintf - "Stats - dead code: deleted %d instructions, %d blocks, %d parameters@." + "Stats - dead code: deleted %d instructions, %d blocks, %d parameters, %d \ + branches@." st.deleted_instrs st.deleted_blocks - st.deleted_params; + st.deleted_params + st.block_shortcut; if debug_stats () then Code.check_updates ~name:"deadcode" previous_p p - ~updates:(st.deleted_instrs + st.deleted_blocks + st.deleted_params); + ~updates: + (st.deleted_instrs + st.deleted_blocks + st.deleted_params + st.block_shortcut); + let p = remove_unused_blocks p in p, st.live diff --git a/compiler/lib/deadcode.mli b/compiler/lib/deadcode.mli index 88d2548af2..13292a6e84 100644 --- a/compiler/lib/deadcode.mli +++ b/compiler/lib/deadcode.mli @@ -23,4 +23,4 @@ type variable_uses = val f : Code.program -> Code.program * variable_uses -val remove_empty_blocks : live_vars:variable_uses -> Code.program -> Code.program +val remove_unused_blocks : Code.program -> Code.program diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 8e22af8e7f..2f4872bc99 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -51,8 +51,8 @@ let deadcode' p = Deadcode.f p let deadcode p = - let r, live_vars = deadcode' p in - Deadcode.remove_empty_blocks ~live_vars r + let r, _ = deadcode' p in + r let inline p = if Config.Flag.inline () && Config.Flag.deadcode () @@ -102,8 +102,6 @@ let effects ~deadcode_sentinal p = | `Cps | `Double_translation -> if debug () then Format.eprintf "Effects...@."; let p, live_vars = Deadcode.f p in - let p = Deadcode.remove_empty_blocks ~live_vars p in - let p, live_vars = Deadcode.f p in let info = Global_flow.f ~fast:false p in let p, live_vars = if Config.Flag.globaldeadcode () @@ -144,51 +142,43 @@ let print p = if debug () then Code.Print.program Format.err_formatter (fun _ _ -> "") p; p +let stats = Debug.find "stats" + let rec loop max name round i (p : 'a) : 'a = - if times () then Format.eprintf "%s#%d...@." name i; - let p' = round p in + let debug = times () || stats () in + if debug then Format.eprintf "%s#%d...@." name i; + let p' = round ~first:(i = 1) p in if i >= max then ( - if times () then Format.eprintf "%s#%d: couldn't reach fix point.@." name i; + if debug then Format.eprintf "%s#%d: couldn't reach fix point.@." name i; p') else if Code.equal p' p then ( - if times () then Format.eprintf "%s#%d: fix-point reached.@." name i; + if debug then Format.eprintf "%s#%d: fix-point reached.@." name i; p') else loop max name round (i + 1) p' -(* o1 *) - -let o1 : 'a -> 'a = +let round ~first : 'a -> 'a = print +> tailcall - +> flow - +> specialize - +> eval - +> inline (* inlining may reveal new tailcall opt *) - +> deadcode - +> tailcall - +> phi + +> (if first then Fun.id else phi) +> flow +> specialize +> eval +> inline +> deadcode - +> print - +> flow - +> specialize - +> eval - +> inline - +> deadcode - +> phi + +(* o1 *) + +let o1 = loop 2 "round" round 1 +> phi +> flow +> specialize +> eval +> print (* o2 *) -let o2 = loop 10 "o1" o1 1 +> print +let o2 = loop 10 "round" round 1 +> print (* o3 *) -let o3 = loop 10 "o1" o1 1 +> print +let o3 = loop 30 "round" round 1 +> print let generate ~exported_runtime diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index c38d5231bc..bc30fd18c7 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -675,19 +675,14 @@ let the_cond_of info x = let eval_branch update_branch info l = match l with | Cond (x, ftrue, ffalse) as b -> ( - if cont_equal ftrue ffalse - then ( - incr update_branch; - Branch ftrue) - else - match the_cond_of info x with - | Zero -> - incr update_branch; - Branch ffalse - | Non_zero -> - incr update_branch; - Branch ftrue - | Unknown -> b) + match the_cond_of info x with + | Zero -> + incr update_branch; + Branch ffalse + | Non_zero -> + incr update_branch; + Branch ftrue + | Unknown -> b) | Switch (x, a) as b -> ( match the_cont_of info x a with | Some cont -> @@ -814,4 +809,5 @@ let f info p = previous_p p ~updates:(!update_count + !inline_constant + !drop_count + !update_branch); + let p = Deadcode.remove_unused_blocks p in p diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index c647570f87..02911119c5 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -340,9 +340,11 @@ let f p live_vars = closures, p) (closures, p) in + (* Inlining a raising function can result in empty blocks *) if times () then Format.eprintf " inlining: %a@." Timer.print t; if stats () then Format.eprintf "Stats - inline: %d optimizations@." !inline_count; if debug_stats () then Code.check_updates ~name:"inline" previous_p p ~updates:!inline_count; + let p = Deadcode.remove_unused_blocks p in Code.invariant p; p diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 9ebd7eb3d0..6e35734b3f 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -880,7 +880,8 @@ let rec compile_block blocks debug_data code pc state : unit = let last = match last with | Branch (pc, _) -> Branch (mk_cont pc) - | Cond (x, (pc1, _), (pc2, _)) -> Cond (x, mk_cont pc1, mk_cont pc2) + | Cond (x, (pc1, _), (pc2, _)) -> + if pc1 = pc2 then Branch (mk_cont pc1) else Cond (x, mk_cont pc1, mk_cont pc2) | Poptrap (pc, _) -> Poptrap (mk_cont pc) | Switch (x, a) -> Switch (x, Array.map a ~f:(fun (pc, _) -> mk_cont pc)) | Raise _ | Return _ | Stop -> last diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index d8bfa3cf73..ceeaaf5b7c 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -475,5 +475,5 @@ let f_once_after p = (fun block -> { block with Code.body = List.map block.body ~f }) p.blocks in - { p with blocks } + Deadcode.remove_unused_blocks { p with blocks } else p diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js index d53d538723..788f32573b 100644 --- a/compiler/tests-full/stdlib.cma.expected.js +++ b/compiler/tests-full/stdlib.cma.expected.js @@ -3952,29 +3952,25 @@ ys$1 = ys[2], y = ys[1], block = /*<>*/ [0, y, 24029], - offset = 1, xs$1 = /*<>*/ xs, ys$4 = ys$1, - offset$1 = offset, + offset$0 = 1, dst$1 = block; for(;;){ - var - dst = /*<>*/ dst$1, - offset$0 = offset$1, - ys$2 = ys$4; + var dst = /*<>*/ dst$1, offset = offset$0, ys$2 = ys$4; for(;;){ if(! ys$2) break; var ys$3 = ys$2[2], y$0 = ys$2[1], dst$0 = /*<>*/ [0, y$0, 24029]; - dst[1 + offset$0] = dst$0; + dst[1 + offset] = dst$0; dst = dst$0; - offset$0 = 1; + offset = 1; ys$2 = ys$3; } /*<>*/ if(! xs$1){ - /*<>*/ dst[1 + offset$0] = 0; + /*<>*/ dst[1 + offset] = 0; /*<>*/ return block; } var @@ -3983,7 +3979,7 @@ ys$0 = /*<>*/ caml_call1(f, x$0); /*<>*/ xs$1 = xs$0; ys$4 = ys$0; - offset$1 = offset$0; + offset$0 = offset; dst$1 = dst; } } @@ -10740,10 +10736,10 @@ (Stdlib[8], 1); var r$0 = /*<>*/ param$0[3], - v$0 = param$0[2], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, param = l$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, param = l$0; break; } param$0 = r$0; @@ -10765,10 +10761,10 @@ if(! param$0) /*<>*/ return 0; var r$0 = /*<>*/ param$0[3], - v$0 = param$0[2], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, param = l$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, param = l$0; break; } param$0 = r$0; @@ -10793,10 +10789,10 @@ (Stdlib[8], 1); var r$0 = /*<>*/ param$0[3], - v$0 = param$0[2], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, param = r$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, param = r$0; break; } param$0 = l$0; @@ -10818,10 +10814,10 @@ if(! param$0) /*<>*/ return 0; var r$0 = /*<>*/ param$0[3], - v$0 = param$0[2], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, param = r$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, param = r$0; break; } param$0 = l$0; @@ -11304,11 +11300,11 @@ (Stdlib[8], 1); var r$0 = /*<>*/ param$0[4], - d$0 = param$0[3], - v$0 = param$0[2], + d0$0 = param$0[3], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, d0 = d$0, param = l$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, d0 = d0$0, param = l$0; break; } param$0 = r$0; @@ -11336,11 +11332,11 @@ if(! param$0) /*<>*/ return 0; var r$0 = /*<>*/ param$0[4], - d$0 = param$0[3], - v$0 = param$0[2], + d0$0 = param$0[3], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, d0 = d$0, param = l$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, d0 = d0$0, param = l$0; break; } param$0 = r$0; @@ -11370,11 +11366,11 @@ (Stdlib[8], 1); var r$0 = /*<>*/ param$0[4], - d$0 = param$0[3], - v$0 = param$0[2], + d0$0 = param$0[3], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, d0 = d$0, param = r$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, d0 = d0$0, param = r$0; break; } param$0 = l$0; @@ -11402,11 +11398,11 @@ if(! param$0) /*<>*/ return 0; var r$0 = /*<>*/ param$0[4], - d$0 = param$0[3], - v$0 = param$0[2], + d0$0 = param$0[3], + v0$0 = param$0[2], l$0 = param$0[1]; - /*<>*/ if(caml_call1(f, v$0)){ - var v0 = /*<>*/ v$0, d0 = d$0, param = r$0; + /*<>*/ if(caml_call1(f, v0$0)){ + var v0 = /*<>*/ v0$0, d0 = d0$0, param = r$0; break; } param$0 = l$0; @@ -22416,7 +22412,7 @@ /*<>*/ caml_call1(Stdlib[103], 0); } catch(exn){} - /*<>*/ try{ + /*<>*/ try{ var _z_ = /*<>*/ caml_call2 diff --git a/dune-workspace b/dune-workspace index 581a0ecbea..c59ccd0377 100644 --- a/dune-workspace +++ b/dune-workspace @@ -7,5 +7,5 @@ (runtest_alias runtest-wasm)) (js_of_ocaml ;; enable for debugging -;; (flags (:standard --debug stats-debug)) +;; (flags (:standard --debug stats-debug --debug invariant)) (runtest_alias runtest-js)))) \ No newline at end of file