|
| 1 | +open! Stdlib |
| 2 | +open Code |
| 3 | + |
| 4 | +(* |
| 5 | +ocamlc does not perform reference unboxing when emitting debugging |
| 6 | +information. Inlining can also enable additional reference unboxing. |
| 7 | +
|
| 8 | +We currently does not unbox references which are used within the scope |
| 9 | +of an exception handler. This should often not result in significant |
| 10 | +performance improvements, and is tricky to get right. Indeed, we would |
| 11 | +need to introduce variables for these references right before the |
| 12 | +[Pushtrap], and then add [Assign] instructions to keep their contents |
| 13 | +up to date whenever a reference is updated. |
| 14 | +*) |
| 15 | + |
| 16 | +let debug = Debug.find "unbox-refs" |
| 17 | + |
| 18 | +let times = Debug.find "times" |
| 19 | + |
| 20 | +let stats = Debug.find "stats" |
| 21 | + |
| 22 | +let rewrite refs block m = |
| 23 | + let m, l = |
| 24 | + List.fold_left |
| 25 | + ~f:(fun (m, rem) i -> |
| 26 | + match i with |
| 27 | + | Let (x, Block (0, [| y |], (NotArray | Unknown), Maybe_mutable)) |
| 28 | + when Var.Set.mem x refs -> Var.Map.add x y m, rem |
| 29 | + | Let (y, Field (x, 0, Non_float)) when Var.Map.mem x m -> |
| 30 | + (* Optimized away by Phisimpl *) |
| 31 | + m, Let (y, Prim (Extern "%identity", [ Pv (Var.Map.find x m) ])) :: rem |
| 32 | + | Offset_ref (x, n) when Var.Map.mem x m -> |
| 33 | + let y = Var.fresh () in |
| 34 | + ( Var.Map.add x y m |
| 35 | + , Let |
| 36 | + ( y |
| 37 | + , Prim |
| 38 | + ( Extern "%int_add" |
| 39 | + , [ Pv (Var.Map.find x m); Pc (Int (Targetint.of_int_exn n)) ] ) ) |
| 40 | + :: rem ) |
| 41 | + | Set_field (x, _, Non_float, y) when Var.Map.mem x m -> Var.Map.add x y m, rem |
| 42 | + | Event _ |
| 43 | + when match rem with |
| 44 | + | Event _ :: _ -> true |
| 45 | + | _ -> false -> m, rem |
| 46 | + | _ -> m, i :: rem) |
| 47 | + block.body |
| 48 | + ~init:(m, []) |
| 49 | + in |
| 50 | + m, List.rev l |
| 51 | + |
| 52 | +let rewrite_cont relevant_vars vars (pc', args) = |
| 53 | + let refs, _ = Int.Hashtbl.find relevant_vars pc' in |
| 54 | + let vars = Var.Map.filter (fun x _ -> Var.Set.mem x refs) vars in |
| 55 | + pc', List.map ~f:snd (Var.Map.bindings vars) @ args |
| 56 | + |
| 57 | +let rewrite_function p variables pc = |
| 58 | + let relevant_vars = Int.Hashtbl.create 16 in |
| 59 | + let g = Structure.(dominator_tree (build_graph p.blocks pc)) in |
| 60 | + let rec traverse_tree g pc vars = |
| 61 | + let block = Addr.Map.find pc p.blocks in |
| 62 | + let vars' = |
| 63 | + List.fold_left |
| 64 | + ~f:(fun s i -> |
| 65 | + match i with |
| 66 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) |
| 67 | + when Var.Hashtbl.mem variables x -> Var.Set.add x s |
| 68 | + | _ -> s) |
| 69 | + ~init:vars |
| 70 | + block.body |
| 71 | + in |
| 72 | + Int.Hashtbl.add relevant_vars pc (vars, vars'); |
| 73 | + Addr.Set.iter (fun pc' -> traverse_tree g pc' vars') (Structure.get_edges g pc) |
| 74 | + in |
| 75 | + traverse_tree g pc Var.Set.empty; |
| 76 | + let rec traverse_tree' g pc blocks = |
| 77 | + let block = Addr.Map.find pc p.blocks in |
| 78 | + let vars, refs = Int.Hashtbl.find relevant_vars pc in |
| 79 | + let vars = |
| 80 | + Var.Set.fold (fun x m -> Var.Map.add x (Var.fork x) m) vars Var.Map.empty |
| 81 | + in |
| 82 | + let params = List.map ~f:snd (Var.Map.bindings vars) @ block.params in |
| 83 | + let vars, body = rewrite refs block vars in |
| 84 | + let branch = |
| 85 | + match block.branch with |
| 86 | + | Return _ | Raise _ | Stop -> block.branch |
| 87 | + | Branch cont -> Branch (rewrite_cont relevant_vars vars cont) |
| 88 | + | Cond (x, cont, cont') -> |
| 89 | + Cond |
| 90 | + ( x |
| 91 | + , rewrite_cont relevant_vars vars cont |
| 92 | + , rewrite_cont relevant_vars vars cont' ) |
| 93 | + | Switch (x, a) -> |
| 94 | + Switch (x, Array.map ~f:(fun cont -> rewrite_cont relevant_vars vars cont) a) |
| 95 | + | Pushtrap (cont, x, cont') -> |
| 96 | + Pushtrap |
| 97 | + ( rewrite_cont relevant_vars vars cont |
| 98 | + , x |
| 99 | + , rewrite_cont relevant_vars vars cont' ) |
| 100 | + | Poptrap cont -> Poptrap (rewrite_cont relevant_vars vars cont) |
| 101 | + in |
| 102 | + let blocks = Addr.Map.add pc { params; body; branch } blocks in |
| 103 | + Addr.Set.fold |
| 104 | + (fun pc' blocks -> traverse_tree' g pc' blocks) |
| 105 | + (Structure.get_edges g pc) |
| 106 | + blocks |
| 107 | + in |
| 108 | + let blocks = traverse_tree' g pc p.blocks in |
| 109 | + { p with blocks } |
| 110 | + |
| 111 | +let f p = |
| 112 | + let t = Timer.make () in |
| 113 | + let candidates = Var.Hashtbl.create 128 in |
| 114 | + let updated = Var.Hashtbl.create 128 in |
| 115 | + let visited = BitSet.create' p.free_pc in |
| 116 | + let discard x = Var.Hashtbl.remove candidates x in |
| 117 | + let check_field_access depth x = |
| 118 | + match Var.Hashtbl.find candidates x with |
| 119 | + | exception Not_found -> false |
| 120 | + | depth' -> |
| 121 | + if depth' = depth |
| 122 | + then true |
| 123 | + else ( |
| 124 | + Var.Hashtbl.remove candidates x; |
| 125 | + false) |
| 126 | + in |
| 127 | + let rec traverse depth start_pc pc = |
| 128 | + if not (BitSet.mem visited pc) |
| 129 | + then ( |
| 130 | + BitSet.set visited pc; |
| 131 | + let block = Addr.Map.find pc p.blocks in |
| 132 | + List.iter |
| 133 | + ~f:(fun i -> |
| 134 | + match i with |
| 135 | + | Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) -> |
| 136 | + Freevars.iter_instr_free_vars discard i; |
| 137 | + Var.Hashtbl.replace candidates x depth |
| 138 | + | Let (_, Closure (_, (pc', _), _)) -> traverse (depth + 1) pc' pc' |
| 139 | + | Let (_, Field (x, 0, Non_float)) -> ignore (check_field_access depth x) |
| 140 | + | Offset_ref (x, _) -> |
| 141 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 142 | + | Set_field (x, _, Non_float, y) -> |
| 143 | + discard y; |
| 144 | + if check_field_access depth x then Var.Hashtbl.replace updated x start_pc |
| 145 | + | _ -> Freevars.iter_instr_free_vars discard i) |
| 146 | + block.body; |
| 147 | + Freevars.iter_last_free_var discard block.branch; |
| 148 | + match block.branch with |
| 149 | + | Pushtrap ((pc', _), _, (pc'', _)) -> |
| 150 | + traverse (depth + 1) start_pc pc'; |
| 151 | + traverse depth start_pc pc'' |
| 152 | + | Poptrap (pc', _) -> traverse (depth - 1) start_pc pc' |
| 153 | + | _ -> Code.fold_children p.blocks pc (fun pc' () -> traverse depth start_pc pc') ()) |
| 154 | + in |
| 155 | + traverse 0 p.start p.start; |
| 156 | + if debug () |
| 157 | + then |
| 158 | + Print.program |
| 159 | + Format.err_formatter |
| 160 | + (fun _ i -> |
| 161 | + match i with |
| 162 | + | Instr (Let (x, _)) |
| 163 | + when Var.Hashtbl.mem candidates x && Var.Hashtbl.mem updated x -> "REF" |
| 164 | + | _ -> "") |
| 165 | + p; |
| 166 | + Var.Hashtbl.filter_map_inplace |
| 167 | + (fun x _depth -> try Some (Var.Hashtbl.find updated x) with Not_found -> None) |
| 168 | + candidates; |
| 169 | + let functions = |
| 170 | + Var.Hashtbl.fold (fun _ pc s -> Addr.Set.add pc s) candidates Addr.Set.empty |
| 171 | + in |
| 172 | + let p = Addr.Set.fold (fun pc p -> rewrite_function p candidates pc) functions p in |
| 173 | + if times () then Format.eprintf " reference unboxing: %a@." Timer.print t; |
| 174 | + if stats () |
| 175 | + then Format.eprintf "Stats - reference unboxing: %d@." (Var.Hashtbl.length candidates); |
| 176 | + p |
0 commit comments