Skip to content

Commit 1fb9e6a

Browse files
vouillonvouillon
committed
Reference unboxing
1 parent 0589e90 commit 1fb9e6a

File tree

3 files changed

+164
-0
lines changed

3 files changed

+164
-0
lines changed

‎compiler/lib/driver.ml

+1
Original file line numberDiff line numberDiff line change
@@ -178,6 +178,7 @@ let o1 : 'a -> 'a =
178178
+> flow
179179
+> specialize
180180
+> eval
181+
+> Ref_unboxing.f
181182
+> inline
182183
+> deadcode
183184
+> phi

‎compiler/lib/phisimpl.ml

+4
Original file line numberDiff line numberDiff line change
@@ -67,6 +67,10 @@ let program_deps { blocks; _ } =
6767
(fun _pc block ->
6868
List.iter block.body ~f:(fun i ->
6969
match i with
70+
| Let (x, Prim (Extern "%identity", [ Pv y ])) ->
71+
add_var vars x;
72+
add_dep deps x y;
73+
add_def vars defs x y
7074
| Let (x, e) ->
7175
add_var vars x;
7276
expr_deps blocks vars deps defs x e

‎compiler/lib/ref_unboxing.ml

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

0 commit comments

Comments
 (0)