Skip to content

Commit 738d492

Browse files
vouillonvouillon
committed
Reference unboxing
1 parent 19575a8 commit 738d492

File tree

3 files changed

+177
-0
lines changed

3 files changed

+177
-0
lines changed

‎compiler/lib/driver.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -167,6 +167,7 @@ let round ~first : 'a -> 'a =
167167
+> flow
168168
+> specialize
169169
+> eval
170+
+> Ref_unboxing.f
170171
+> inline
171172
+> deadcode
172173

‎compiler/lib/phisimpl.ml

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,10 @@ let program_deps { blocks; _ } =
6969
(fun _pc block ->
7070
List.iter block.body ~f:(fun i ->
7171
match i with
72+
| Let (x, Prim (Extern "%identity", [ Pv y ])) ->
73+
add_var vars x;
74+
add_dep deps x y;
75+
add_def vars defs x y
7276
| Let (x, e) ->
7377
add_var vars x;
7478
expr_deps blocks vars deps defs x e

‎compiler/lib/ref_unboxing.ml

Lines changed: 172 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,172 @@
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+
TODO:
9+
- appropriate order
10+
- handle assignment in handler
11+
If a ref is used in an exception handler:
12+
- add block that binds the contents of the reference right before pushtrap
13+
- insert assignements for each update
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+
| _ -> m, i :: rem)
43+
block.body
44+
~init:(m, [])
45+
in
46+
m, List.rev l
47+
48+
let rewrite_cont relevant_vars vars (pc', args) =
49+
let refs, _ = Hashtbl.find relevant_vars pc' in
50+
let vars = Var.Map.filter (fun x _ -> Var.Set.mem x refs) vars in
51+
pc', List.map ~f:snd (Var.Map.bindings vars) @ args
52+
53+
let rewrite_function p variables pc =
54+
let relevant_vars = Hashtbl.create 16 in
55+
let g = Structure.(dominator_tree (build_graph p.blocks pc)) in
56+
let rec traverse_tree g pc vars =
57+
let block = Addr.Map.find pc p.blocks in
58+
let vars' =
59+
List.fold_left
60+
~f:(fun s i ->
61+
match i with
62+
| Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable))
63+
when Var.Hashtbl.mem variables x -> Var.Set.add x s
64+
| _ -> s)
65+
~init:vars
66+
block.body
67+
in
68+
Hashtbl.add relevant_vars pc (vars, vars');
69+
Addr.Set.iter (fun pc' -> traverse_tree g pc' vars') (Structure.get_edges g pc)
70+
in
71+
traverse_tree g pc Var.Set.empty;
72+
let rec traverse_tree' g pc blocks =
73+
let block = Addr.Map.find pc p.blocks in
74+
let vars, refs = Hashtbl.find relevant_vars pc in
75+
let vars =
76+
Var.Set.fold (fun x m -> Var.Map.add x (Var.fork x) m) vars Var.Map.empty
77+
in
78+
let params = List.map ~f:snd (Var.Map.bindings vars) @ block.params in
79+
let vars, body = rewrite refs block vars in
80+
let branch =
81+
match block.branch with
82+
| Return _ | Raise _ | Stop -> block.branch
83+
| Branch cont -> Branch (rewrite_cont relevant_vars vars cont)
84+
| Cond (x, cont, cont') ->
85+
Cond
86+
( x
87+
, rewrite_cont relevant_vars vars cont
88+
, rewrite_cont relevant_vars vars cont' )
89+
| Switch (x, a) ->
90+
Switch (x, Array.map ~f:(fun cont -> rewrite_cont relevant_vars vars cont) a)
91+
| Pushtrap (cont, x, cont') ->
92+
Pushtrap
93+
( rewrite_cont relevant_vars vars cont
94+
, x
95+
, rewrite_cont relevant_vars vars cont' )
96+
| Poptrap cont -> Poptrap (rewrite_cont relevant_vars vars cont)
97+
in
98+
let blocks = Addr.Map.add pc { params; body; branch } blocks in
99+
Addr.Set.fold
100+
(fun pc' blocks -> traverse_tree' g pc' blocks)
101+
(Structure.get_edges g pc)
102+
blocks
103+
in
104+
let blocks = traverse_tree' g pc p.blocks in
105+
{ p with blocks }
106+
107+
let f p =
108+
let t = Timer.make () in
109+
let candidates = Var.Hashtbl.create 128 in
110+
let updated = Var.Hashtbl.create 128 in
111+
let visited = BitSet.create' p.free_pc in
112+
let discard x = Var.Hashtbl.remove candidates x in
113+
let check_field_access depth x =
114+
match Var.Hashtbl.find candidates x with
115+
| exception Not_found -> false
116+
| depth' ->
117+
if depth' = depth
118+
then true
119+
else (
120+
Var.Hashtbl.remove candidates x;
121+
false)
122+
in
123+
let rec traverse depth start_pc pc =
124+
if not (BitSet.mem visited pc)
125+
then (
126+
BitSet.set visited pc;
127+
let block = Addr.Map.find pc p.blocks in
128+
List.iter
129+
~f:(fun i ->
130+
match i with
131+
| Let (x, Block (0, [| _ |], (NotArray | Unknown), Maybe_mutable)) ->
132+
Freevars.iter_instr_free_vars discard i;
133+
Var.Hashtbl.replace candidates x depth
134+
| Let (_, Closure (_, (pc', _), _)) -> traverse (depth + 1) pc' pc'
135+
| Let (_, Field (x, 0, Non_float)) -> ignore (check_field_access depth x)
136+
| Offset_ref (x, _) ->
137+
if check_field_access depth x then Var.Hashtbl.replace updated x start_pc
138+
| Set_field (x, _, Non_float, y) ->
139+
discard y;
140+
if check_field_access depth x then Var.Hashtbl.replace updated x start_pc
141+
| _ -> Freevars.iter_instr_free_vars discard i)
142+
block.body;
143+
Freevars.iter_last_free_var discard block.branch;
144+
match block.branch with
145+
| Pushtrap ((pc', _), _, (pc'', _)) ->
146+
traverse (depth + 1) start_pc pc';
147+
traverse depth start_pc pc''
148+
| Poptrap (pc', _) -> traverse (depth - 1) start_pc pc'
149+
| _ -> Code.fold_children p.blocks pc (fun pc' () -> traverse depth start_pc pc') ())
150+
in
151+
traverse 0 p.start p.start;
152+
if debug ()
153+
then
154+
Print.program
155+
Format.err_formatter
156+
(fun _ i ->
157+
match i with
158+
| Instr (Let (x, _))
159+
when Var.Hashtbl.mem candidates x && Var.Hashtbl.mem updated x -> "REF"
160+
| _ -> "")
161+
p;
162+
Var.Hashtbl.filter_map_inplace
163+
(fun x _depth -> try Some (Var.Hashtbl.find updated x) with Not_found -> None)
164+
candidates;
165+
let functions =
166+
Var.Hashtbl.fold (fun _ pc s -> Addr.Set.add pc s) candidates Addr.Set.empty
167+
in
168+
let p = Addr.Set.fold (fun pc p -> rewrite_function p candidates pc) functions p in
169+
if times () then Format.eprintf " reference unboxing: %a@." Timer.print t;
170+
if stats ()
171+
then Format.eprintf "Stats - reference unboxing: %d@." (Var.Hashtbl.length candidates);
172+
p

0 commit comments

Comments
 (0)