|
| 1 | +(* Js_of_ocaml compiler |
| 2 | + * http://www.ocsigen.org/js_of_ocaml/ |
| 3 | + * |
| 4 | + * This program is free software; you can redistribute it and/or modify |
| 5 | + * it under the terms of the GNU Lesser General Public License as published by |
| 6 | + * the Free Software Foundation, with linking exception; |
| 7 | + * either version 2.1 of the License, or (at your option) any later version. |
| 8 | + * |
| 9 | + * This program is distributed in the hope that it will be useful, |
| 10 | + * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 11 | + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 12 | + * GNU Lesser General Public License for more details. |
| 13 | + * |
| 14 | + * You should have received a copy of the GNU Lesser General Public License |
| 15 | + * along with this program; if not, write to the Free Software |
| 16 | + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 17 | + *) |
| 18 | + |
| 19 | +open! Stdlib |
| 20 | +open Code |
| 21 | + |
| 22 | +(* |
| 23 | +ocamlc does not perform reference unboxing when emitting debugging |
| 24 | +information. Inlining can also enable additional reference unboxing. |
| 25 | +
|
| 26 | +We currently does not unbox references which are used within the scope |
| 27 | +of an exception handler. This should often not result in significant |
| 28 | +performance improvements, and is tricky to get right. Indeed, we would |
| 29 | +need to introduce variables for these references right before the |
| 30 | +[Pushtrap], and then add [Assign] instructions to keep their contents |
| 31 | +up to date whenever a reference is updated. |
| 32 | +*) |
| 33 | + |
| 34 | +let debug = Debug.find "unbox-refs" |
| 35 | + |
| 36 | +let times = Debug.find "times" |
| 37 | + |
| 38 | +let stats = Debug.find "stats" |
| 39 | + |
| 40 | +let rewrite refs block m = |
| 41 | + let m, l = |
| 42 | + List.fold_left |
| 43 | + ~f:(fun (m, acc) i -> |
| 44 | + match i with |
| 45 | + | Let (x, Block (0, [| y |], (NotArray | Unknown), Maybe_mutable)) |
| 46 | + when Var.Set.mem x refs -> Var.Map.add x y m, acc |
| 47 | + | Let (y, Field (x, 0, Non_float)) when Var.Map.mem x m -> |
| 48 | + (* Optimized away by Phisimpl *) |
| 49 | + m, Let (y, Prim (Extern "%identity", [ Pv (Var.Map.find x m) ])) :: acc |
| 50 | + | Offset_ref (x, n) when Var.Map.mem x m -> |
| 51 | + let y = Var.fresh () in |
| 52 | + ( Var.Map.add x y m |
| 53 | + , Let |
| 54 | + ( y |
| 55 | + , Prim |
| 56 | + ( Extern "%int_add" |
| 57 | + , [ Pv (Var.Map.find x m); Pc (Int (Targetint.of_int_exn n)) ] ) ) |
| 58 | + :: acc ) |
| 59 | + | Set_field (x, 0, Non_float, y) when Var.Map.mem x m -> Var.Map.add x y m, acc |
| 60 | + | Event _ -> ( |
| 61 | + ( m |
| 62 | + , match acc with |
| 63 | + | Event _ :: prev -> |
| 64 | + (* Avoid consecutive events (keep just the last one) *) |
| 65 | + i :: prev |
| 66 | + | _ -> i :: acc )) |
| 67 | + | _ -> m, i :: acc) |
| 68 | + block.body |
| 69 | + ~init:(m, []) |
| 70 | + in |
| 71 | + m, List.rev l |
| 72 | + |
| 73 | +let rewrite_cont relevant_vars vars (pc', args) = |
| 74 | + let refs, _ = Int.Hashtbl.find relevant_vars pc' in |
| 75 | + let vars = Var.Map.filter (fun x _ -> Var.Set.mem x refs) vars in |
| 76 | + pc', List.map ~f:snd (Var.Map.bindings vars) @ args |
| 77 | + |
| 78 | +let rewrite_function p variables pc = |
| 79 | + let relevant_vars = Int.Hashtbl.create 16 in |
| 80 | + let g = Structure.(dominator_tree (build_graph p.blocks pc)) in |
| 81 | + let rec traverse_tree g pc refs = |
| 82 | + let block = Addr.Map.find pc p.blocks in |
| 83 | + let refs' = |
| 84 | + List.fold_left |
| 85 | + ~f:(fun s i -> |
| 86 | + match i with |
| 87 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) |
| 88 | + when Var.Hashtbl.mem variables x -> Var.Set.add x s |
| 89 | + | _ -> s) |
| 90 | + ~init:refs |
| 91 | + block.body |
| 92 | + in |
| 93 | + Int.Hashtbl.add relevant_vars pc (refs, refs'); |
| 94 | + Addr.Set.iter (fun pc' -> traverse_tree g pc' refs') (Structure.get_edges g pc) |
| 95 | + in |
| 96 | + traverse_tree g pc Var.Set.empty; |
| 97 | + let rec traverse_tree' g pc blocks = |
| 98 | + let block = Addr.Map.find pc p.blocks in |
| 99 | + let refs, refs' = Int.Hashtbl.find relevant_vars pc in |
| 100 | + let vars = |
| 101 | + Var.Set.fold (fun x m -> Var.Map.add x (Var.fork x) m) refs Var.Map.empty |
| 102 | + in |
| 103 | + let params = List.map ~f:snd (Var.Map.bindings vars) @ block.params in |
| 104 | + let vars, body = rewrite refs' block vars in |
| 105 | + let branch = |
| 106 | + match block.branch with |
| 107 | + | Return _ | Raise _ | Stop -> block.branch |
| 108 | + | Branch cont -> Branch (rewrite_cont relevant_vars vars cont) |
| 109 | + | Cond (x, cont, cont') -> |
| 110 | + Cond |
| 111 | + ( x |
| 112 | + , rewrite_cont relevant_vars vars cont |
| 113 | + , rewrite_cont relevant_vars vars cont' ) |
| 114 | + | Switch (x, a) -> |
| 115 | + Switch (x, Array.map ~f:(fun cont -> rewrite_cont relevant_vars vars cont) a) |
| 116 | + | Pushtrap (cont, x, cont') -> |
| 117 | + Pushtrap |
| 118 | + ( rewrite_cont relevant_vars vars cont |
| 119 | + , x |
| 120 | + , rewrite_cont relevant_vars vars cont' ) |
| 121 | + | Poptrap cont -> Poptrap (rewrite_cont relevant_vars vars cont) |
| 122 | + in |
| 123 | + let blocks = Addr.Map.add pc { params; body; branch } blocks in |
| 124 | + Addr.Set.fold |
| 125 | + (fun pc' blocks -> traverse_tree' g pc' blocks) |
| 126 | + (Structure.get_edges g pc) |
| 127 | + blocks |
| 128 | + in |
| 129 | + let blocks = traverse_tree' g pc p.blocks in |
| 130 | + { p with blocks } |
| 131 | + |
| 132 | +let f p = |
| 133 | + let t = Timer.make () in |
| 134 | + let candidates = Var.Hashtbl.create 128 in |
| 135 | + let updated = Var.Hashtbl.create 128 in |
| 136 | + let visited = BitSet.create' p.free_pc in |
| 137 | + let discard x = Var.Hashtbl.remove candidates x in |
| 138 | + let check_field_access depth x = |
| 139 | + match Var.Hashtbl.find candidates x with |
| 140 | + | exception Not_found -> false |
| 141 | + | depth' -> |
| 142 | + if depth' = depth |
| 143 | + then true |
| 144 | + else ( |
| 145 | + Var.Hashtbl.remove candidates x; |
| 146 | + false) |
| 147 | + in |
| 148 | + (* A reference can be defined within the scope of an exception |
| 149 | + handler and used within the scope of another exception handler. |
| 150 | + So exception handlers should have strictly increasing depths |
| 151 | + within a function. [max_depth] is the largest depth used so far |
| 152 | + inside a function. This way, we know which depth to use when |
| 153 | + entering the scope of an exception handler. We use [depth_stack] |
| 154 | + to restore the previous depth when leaving the scope of an |
| 155 | + exception handler. *) |
| 156 | + let rec traverse depth_stack max_depth depth start_pc pc = |
| 157 | + if not (BitSet.mem visited pc) |
| 158 | + then ( |
| 159 | + BitSet.set visited pc; |
| 160 | + let block = Addr.Map.find pc p.blocks in |
| 161 | + List.iter |
| 162 | + ~f:(fun i -> |
| 163 | + match i with |
| 164 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) -> |
| 165 | + Freevars.iter_instr_free_vars discard i; |
| 166 | + Var.Hashtbl.replace candidates x depth |
| 167 | + | Let (_, Closure (_, (pc', _), _)) -> |
| 168 | + traverse [] (max_depth + 1) (max_depth + 1) pc' pc' |
| 169 | + | Let (_, Field (x, 0, Non_float)) -> ignore (check_field_access depth x) |
| 170 | + | Offset_ref (x, _) -> |
| 171 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 172 | + | Set_field (x, _, Non_float, y) -> |
| 173 | + discard y; |
| 174 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 175 | + | _ -> Freevars.iter_instr_free_vars discard i) |
| 176 | + block.body; |
| 177 | + Freevars.iter_last_free_var discard block.branch; |
| 178 | + match block.branch with |
| 179 | + | Pushtrap ((pc', _), _, (pc'', _)) -> |
| 180 | + traverse (depth :: depth_stack) (max_depth + 1) (max_depth + 1) start_pc pc'; |
| 181 | + traverse depth_stack max_depth depth start_pc pc'' |
| 182 | + | Poptrap (pc', _) -> |
| 183 | + traverse (List.tl depth_stack) max_depth (List.hd depth_stack) start_pc pc' |
| 184 | + | _ -> |
| 185 | + Code.fold_children |
| 186 | + p.blocks |
| 187 | + pc |
| 188 | + (fun pc' () -> traverse depth_stack max_depth depth start_pc pc') |
| 189 | + ()) |
| 190 | + in |
| 191 | + traverse [] 0 0 p.start p.start; |
| 192 | + if debug () |
| 193 | + then |
| 194 | + Print.program |
| 195 | + Format.err_formatter |
| 196 | + (fun _ i -> |
| 197 | + match i with |
| 198 | + | Instr (Let (x, _)) |
| 199 | + when Var.Hashtbl.mem candidates x && Var.Hashtbl.mem updated x -> "REF" |
| 200 | + | _ -> "") |
| 201 | + p; |
| 202 | + Var.Hashtbl.filter_map_inplace |
| 203 | + (fun x _depth -> try Some (Var.Hashtbl.find updated x) with Not_found -> None) |
| 204 | + candidates; |
| 205 | + let functions = |
| 206 | + Var.Hashtbl.fold (fun _ pc s -> Addr.Set.add pc s) candidates Addr.Set.empty |
| 207 | + in |
| 208 | + let p = Addr.Set.fold (fun pc p -> rewrite_function p candidates pc) functions p in |
| 209 | + if times () then Format.eprintf " reference unboxing: %a@." Timer.print t; |
| 210 | + if stats () |
| 211 | + then Format.eprintf "Stats - reference unboxing: %d@." (Var.Hashtbl.length candidates); |
| 212 | + p |
0 commit comments