|
| 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 do 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_body unboxed_refs body ref_contents subst = |
| 41 | + let ref_contents, subst, l = |
| 42 | + List.fold_left |
| 43 | + ~f:(fun (ref_contents, subst, acc) i -> |
| 44 | + match i with |
| 45 | + | Let (x, Block (0, [| y |], (NotArray | Unknown), Maybe_mutable)) |
| 46 | + when Var.Set.mem x unboxed_refs -> Var.Map.add x y ref_contents, subst, acc |
| 47 | + | Let (y, Field (x, 0, Non_float)) when Var.Map.mem x ref_contents -> |
| 48 | + ref_contents, Var.Map.add y (Var.Map.find x ref_contents) subst, acc |
| 49 | + | Offset_ref (x, n) when Var.Map.mem x ref_contents -> |
| 50 | + let y = Var.fork x in |
| 51 | + ( Var.Map.add x y ref_contents |
| 52 | + , subst |
| 53 | + , Let |
| 54 | + ( y |
| 55 | + , Prim |
| 56 | + ( Extern "%int_add" |
| 57 | + , [ Pv (Var.Map.find x ref_contents) |
| 58 | + ; Pc (Int (Targetint.of_int_exn n)) |
| 59 | + ] ) ) |
| 60 | + :: acc ) |
| 61 | + | Set_field (x, 0, Non_float, y) when Var.Map.mem x ref_contents -> |
| 62 | + Var.Map.add x y ref_contents, subst, acc |
| 63 | + | Event _ -> ( |
| 64 | + ( ref_contents |
| 65 | + , subst |
| 66 | + , match acc with |
| 67 | + | Event _ :: prev -> |
| 68 | + (* Avoid consecutive events (keep just the last one) *) |
| 69 | + i :: prev |
| 70 | + | _ -> i :: acc )) |
| 71 | + | _ -> ref_contents, subst, i :: acc) |
| 72 | + body |
| 73 | + ~init:(ref_contents, subst, []) |
| 74 | + in |
| 75 | + ref_contents, subst, List.rev l |
| 76 | + |
| 77 | +let rewrite_cont relevant_vars ref_contents (pc', args) = |
| 78 | + let refs, _ = Int.Hashtbl.find relevant_vars pc' in |
| 79 | + let vars = Var.Map.filter (fun x _ -> Var.Set.mem x refs) ref_contents in |
| 80 | + pc', List.map ~f:snd (Var.Map.bindings vars) @ args |
| 81 | + |
| 82 | +let rewrite_branch relevant_vars ref_contents branch = |
| 83 | + match branch with |
| 84 | + | Return _ | Raise _ | Stop -> branch |
| 85 | + | Branch cont -> Branch (rewrite_cont relevant_vars ref_contents cont) |
| 86 | + | Cond (x, cont, cont') -> |
| 87 | + Cond |
| 88 | + ( x |
| 89 | + , rewrite_cont relevant_vars ref_contents cont |
| 90 | + , rewrite_cont relevant_vars ref_contents cont' ) |
| 91 | + | Switch (x, a) -> |
| 92 | + Switch (x, Array.map ~f:(fun cont -> rewrite_cont relevant_vars ref_contents cont) a) |
| 93 | + | Pushtrap (cont, x, cont') -> |
| 94 | + Pushtrap |
| 95 | + ( rewrite_cont relevant_vars ref_contents cont |
| 96 | + , x |
| 97 | + , rewrite_cont relevant_vars ref_contents cont' ) |
| 98 | + | Poptrap cont -> Poptrap (rewrite_cont relevant_vars ref_contents cont) |
| 99 | + |
| 100 | +let rewrite_function p ~unboxed_refs pc subst = |
| 101 | + let g = Structure.(dominator_tree (build_graph p.blocks pc)) in |
| 102 | + let relevant_vars = |
| 103 | + let relevant_vars = Int.Hashtbl.create 16 in |
| 104 | + let rec traverse_tree g pc refs = |
| 105 | + let block = Addr.Map.find pc p.blocks in |
| 106 | + let refs' = |
| 107 | + List.fold_left |
| 108 | + ~f:(fun s i -> |
| 109 | + match i with |
| 110 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) |
| 111 | + when Var.Hashtbl.mem unboxed_refs x -> Var.Set.add x s |
| 112 | + | _ -> s) |
| 113 | + ~init:refs |
| 114 | + block.body |
| 115 | + in |
| 116 | + Int.Hashtbl.add relevant_vars pc (refs, refs'); |
| 117 | + Addr.Set.iter (fun pc' -> traverse_tree g pc' refs') (Structure.get_edges g pc) |
| 118 | + in |
| 119 | + traverse_tree g pc Var.Set.empty; |
| 120 | + relevant_vars |
| 121 | + in |
| 122 | + let rec traverse_tree' g pc blocks subst = |
| 123 | + let block = Addr.Map.find pc p.blocks in |
| 124 | + let refs, refs' = Int.Hashtbl.find relevant_vars pc in |
| 125 | + let ref_contents = |
| 126 | + Var.Set.fold (fun x m -> Var.Map.add x (Var.fork x) m) refs Var.Map.empty |
| 127 | + in |
| 128 | + let params = List.map ~f:snd (Var.Map.bindings ref_contents) @ block.params in |
| 129 | + let ref_contents, subst, body = rewrite_body refs' block.body ref_contents subst in |
| 130 | + let branch = rewrite_branch relevant_vars ref_contents block.branch in |
| 131 | + let blocks = Addr.Map.add pc { params; body; branch } blocks in |
| 132 | + Addr.Set.fold |
| 133 | + (fun pc' (blocks, subst) -> traverse_tree' g pc' blocks subst) |
| 134 | + (Structure.get_edges g pc) |
| 135 | + (blocks, subst) |
| 136 | + in |
| 137 | + let blocks, subst = traverse_tree' g pc p.blocks subst in |
| 138 | + { p with blocks }, subst |
| 139 | + |
| 140 | +let f p = |
| 141 | + let t = Timer.make () in |
| 142 | + let candidates = Var.Hashtbl.create 128 in |
| 143 | + let updated = Var.Hashtbl.create 128 in |
| 144 | + let visited = BitSet.create' p.free_pc in |
| 145 | + let discard x = Var.Hashtbl.remove candidates x in |
| 146 | + let check_field_access depth x = |
| 147 | + match Var.Hashtbl.find candidates x with |
| 148 | + | exception Not_found -> false |
| 149 | + | depth' -> |
| 150 | + if depth' = depth |
| 151 | + then true |
| 152 | + else ( |
| 153 | + Var.Hashtbl.remove candidates x; |
| 154 | + false) |
| 155 | + in |
| 156 | + (* A reference can be defined within the scope of an exception |
| 157 | + handler and used within the scope of another exception handler. |
| 158 | + So exception handlers should have strictly increasing depths |
| 159 | + within a function. [max_depth] is the largest depth used so far |
| 160 | + inside a function. This way, we know which depth to use when |
| 161 | + entering the scope of an exception handler. We use [depth_stack] |
| 162 | + to restore the previous depth when leaving the scope of an |
| 163 | + exception handler. *) |
| 164 | + let rec traverse depth_stack max_depth depth start_pc pc = |
| 165 | + if not (BitSet.mem visited pc) |
| 166 | + then ( |
| 167 | + BitSet.set visited pc; |
| 168 | + let block = Addr.Map.find pc p.blocks in |
| 169 | + List.iter |
| 170 | + ~f:(fun i -> |
| 171 | + match i with |
| 172 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) -> |
| 173 | + Freevars.iter_instr_free_vars discard i; |
| 174 | + Var.Hashtbl.replace candidates x depth |
| 175 | + | Let (_, Closure (_, (pc', _), _)) -> |
| 176 | + traverse [] (max_depth + 1) (max_depth + 1) pc' pc' |
| 177 | + | Let (_, Field (x, 0, Non_float)) -> ignore (check_field_access depth x) |
| 178 | + | Offset_ref (x, _) -> |
| 179 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 180 | + | Set_field (x, _, Non_float, y) -> |
| 181 | + discard y; |
| 182 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 183 | + | _ -> Freevars.iter_instr_free_vars discard i) |
| 184 | + block.body; |
| 185 | + Freevars.iter_last_free_var discard block.branch; |
| 186 | + match block.branch with |
| 187 | + | Pushtrap ((pc', _), _, (pc'', _)) -> |
| 188 | + traverse (depth :: depth_stack) (max_depth + 1) (max_depth + 1) start_pc pc'; |
| 189 | + traverse depth_stack max_depth depth start_pc pc'' |
| 190 | + | Poptrap (pc', _) -> |
| 191 | + traverse (List.tl depth_stack) max_depth (List.hd depth_stack) start_pc pc' |
| 192 | + | _ -> |
| 193 | + Code.fold_children |
| 194 | + p.blocks |
| 195 | + pc |
| 196 | + (fun pc' () -> traverse depth_stack max_depth depth start_pc pc') |
| 197 | + ()) |
| 198 | + in |
| 199 | + traverse [] 0 0 p.start p.start; |
| 200 | + if debug () |
| 201 | + then |
| 202 | + Print.program |
| 203 | + Format.err_formatter |
| 204 | + (fun _ i -> |
| 205 | + match i with |
| 206 | + | Instr (Let (x, _)) |
| 207 | + when Var.Hashtbl.mem candidates x && Var.Hashtbl.mem updated x -> "REF" |
| 208 | + | _ -> "") |
| 209 | + p; |
| 210 | + Var.Hashtbl.filter_map_inplace |
| 211 | + (fun x _depth -> try Some (Var.Hashtbl.find updated x) with Not_found -> None) |
| 212 | + candidates; |
| 213 | + let functions = |
| 214 | + Var.Hashtbl.fold (fun _ pc s -> Addr.Set.add pc s) candidates Addr.Set.empty |
| 215 | + in |
| 216 | + let p, subst = |
| 217 | + Addr.Set.fold |
| 218 | + (fun pc (p, subst) -> rewrite_function p ~unboxed_refs:candidates pc subst) |
| 219 | + functions |
| 220 | + (p, Var.Map.empty) |
| 221 | + in |
| 222 | + let p = |
| 223 | + if Var.Map.is_empty subst |
| 224 | + then p |
| 225 | + else Subst.Excluding_Binders.program (Subst.from_map subst) p |
| 226 | + in |
| 227 | + if times () then Format.eprintf " reference unboxing: %a@." Timer.print t; |
| 228 | + if stats () |
| 229 | + then Format.eprintf "Stats - reference unboxing: %d@." (Var.Hashtbl.length candidates); |
| 230 | + p |
0 commit comments