Skip to content

Commit 42c5f9e

Browse files
vouillonvouillon
committed
Reference unboxing
1 parent 5231118 commit 42c5f9e

File tree

8 files changed

+1357
-1117
lines changed

8 files changed

+1357
-1117
lines changed

‎CHANGES.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,9 @@
22

33
## Features/Changes
44
* Compiler/wasm: omit code pointer from closures when not used (#2059)
5+
* Compiler: reference unboxing (#1958)
6+
7+
## Bug fixes
58
* Compiler: fix purity of comparison functions (again) (#2092)
69

710
# 6.2.0 (2025-07-30) - Lille

‎compiler/lib/driver.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -217,6 +217,7 @@ let round profile : 'a -> 'a =
217217
print
218218
+> tailcall
219219
+> (flow +> specialize +> eval +> fst)
220+
+> Ref_unboxing.f
220221
+> inline profile
221222
+> phi
222223
+> deadcode

‎compiler/lib/phisimpl.ml

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,11 @@ 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+
(* This is introduced by the reference unboxing pass *)
74+
add_var vars x;
75+
add_dep deps x y;
76+
add_def vars defs x y
7277
| Let (x, e) ->
7378
add_var vars x;
7479
expr_deps blocks vars deps defs x e

‎compiler/lib/ref_unboxing.ml

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

‎compiler/tests-compiler/double-translation/effects_continuations.ml

Lines changed: 22 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -101,7 +101,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
101101
[%expect
102102
{|
103103
function exceptions$0(s){
104-
try{var _k_ = caml_int_of_string(s), n = _k_;}
104+
try{var _l_ = caml_int_of_string(s), n = _l_;}
105105
catch(exn$0){
106106
var exn = caml_wrap_exception(exn$0), tag = exn[1];
107107
if(tag !== Stdlib[7]) throw caml_maybe_attach_backtrace(exn, 0);
@@ -110,7 +110,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
110110
try{
111111
if(caml_string_equal(s, cst$0))
112112
throw caml_maybe_attach_backtrace(Stdlib[8], 1);
113-
var _j_ = 7, m = _j_;
113+
var _k_ = 7, m = _k_;
114114
}
115115
catch(exn){
116116
var exn$0 = caml_wrap_exception(exn);
@@ -120,8 +120,8 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
120120
try{
121121
if(caml_string_equal(s, cst))
122122
throw caml_maybe_attach_backtrace(Stdlib[8], 1);
123-
var _i_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]];
124-
return _i_;
123+
var _j_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]];
124+
return _j_;
125125
}
126126
catch(exn){
127127
var exn$1 = caml_wrap_exception(exn);
@@ -131,7 +131,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
131131
}
132132
//end
133133
function exceptions$1(s, cont){
134-
try{var _i_ = caml_int_of_string(s), n = _i_;}
134+
try{var _j_ = caml_int_of_string(s), n = _j_;}
135135
catch(exn){
136136
var exn$2 = caml_wrap_exception(exn), tag = exn$2[1];
137137
if(tag !== Stdlib[7]){
@@ -145,7 +145,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
145145
try{
146146
if(caml_string_equal(s, cst$0))
147147
throw caml_maybe_attach_backtrace(Stdlib[8], 1);
148-
var _h_ = 7, m = _h_;
148+
var _i_ = 7, m = _i_;
149149
}
150150
catch(exn$0){
151151
var exn$1 = caml_wrap_exception(exn$0);
@@ -165,9 +165,9 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
165165
return caml_trampoline_cps_call2
166166
(Stdlib[79],
167167
cst_toto,
168-
function(_i_){caml_pop_trap(); return cont([0, [0, _i_, n, m]]);});
169-
var _g_ = Stdlib[8], raise = caml_pop_trap();
170-
return raise(caml_maybe_attach_backtrace(_g_, 1));
168+
function(_j_){caml_pop_trap(); return cont([0, [0, _j_, n, m]]);});
169+
var _h_ = Stdlib[8], raise = caml_pop_trap();
170+
return raise(caml_maybe_attach_backtrace(_h_, 1));
171171
}
172172
//end
173173
var exceptions = caml_cps_closure(exceptions$0, exceptions$1);
@@ -180,10 +180,10 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
180180
}
181181
//end
182182
function cond1$1(b, cont){
183-
function _g_(ic){return cont([0, ic, 7]);}
183+
function _h_(ic){return cont([0, ic, 7]);}
184184
return b
185-
? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _g_)
186-
: caml_trampoline_cps_call2(Stdlib[79], cst_titi, _g_);
185+
? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _h_)
186+
: caml_trampoline_cps_call2(Stdlib[79], cst_titi, _h_);
187187
}
188188
//end
189189
var cond1 = caml_cps_closure(cond1$0, cond1$1);
@@ -197,26 +197,26 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
197197
}
198198
//end
199199
function cond2$1(b, cont){
200-
function _g_(_g_){return cont(7);}
200+
function _h_(_h_){return cont(7);}
201201
return b
202-
? caml_trampoline_cps_call2(Stdlib_Printf[3], _a_, _g_)
203-
: caml_trampoline_cps_call2(Stdlib_Printf[3], _b_, _g_);
202+
? caml_trampoline_cps_call2(Stdlib_Printf[3], _a_, _h_)
203+
: caml_trampoline_cps_call2(Stdlib_Printf[3], _b_, _h_);
204204
}
205205
//end
206206
var cond2 = caml_cps_closure(cond2$0, cond2$1);
207207
//end
208208
function cond3$0(b){
209-
var x = [0, 0];
210-
if(b) x[1] = 1; else caml_call1(Stdlib_Printf[3], _c_);
211-
return x[1];
209+
var x = 0, x$0 = b ? 1 : (caml_call1(Stdlib_Printf[3], _c_), x);
210+
return x$0;
212211
}
213212
//end
214213
function cond3$1(b, cont){
215-
var x = [0, 0];
216-
function _g_(_g_){return cont(x[1]);}
214+
function _g_(x){return cont(x);}
215+
var x = 0;
217216
return b
218-
? (x[1] = 1, _g_(0))
219-
: caml_trampoline_cps_call2(Stdlib_Printf[3], _c_, _g_);
217+
? _g_(1)
218+
: caml_trampoline_cps_call2
219+
(Stdlib_Printf[3], _c_, function(_h_){return _g_(x);});
220220
}
221221
//end
222222
var cond3 = caml_cps_closure(cond3$0, cond3$1);

‎compiler/tests-compiler/effects_continuations.ml

Lines changed: 16 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
102102
[%expect
103103
{|
104104
function exceptions(s, cont){
105-
try{var _i_ = runtime.caml_int_of_string(s), n = _i_;}
105+
try{var _j_ = runtime.caml_int_of_string(s), n = _j_;}
106106
catch(exn$0){
107107
var exn = caml_wrap_exception(exn$0), tag = exn[1];
108108
if(tag !== Stdlib[7]){
@@ -114,7 +114,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
114114
try{
115115
if(caml_string_equal(s, cst$0))
116116
throw caml_maybe_attach_backtrace(Stdlib[8], 1);
117-
var _h_ = 7, m = _h_;
117+
var _i_ = 7, m = _i_;
118118
}
119119
catch(exn){
120120
var exn$0 = caml_wrap_exception(exn);
@@ -136,31 +136,32 @@ let%expect_test "test-compiler/lib-effects/test1.ml" =
136136
return caml_trampoline_cps_call2
137137
(Stdlib[79],
138138
cst_toto,
139-
function(_i_){caml_pop_trap(); return cont([0, [0, _i_, n, m]]);});
140-
var _g_ = Stdlib[8], raise = caml_pop_trap();
141-
return raise(caml_maybe_attach_backtrace(_g_, 1));
139+
function(_j_){caml_pop_trap(); return cont([0, [0, _j_, n, m]]);});
140+
var _h_ = Stdlib[8], raise = caml_pop_trap();
141+
return raise(caml_maybe_attach_backtrace(_h_, 1));
142142
}
143143
//end
144144
function cond1(b, cont){
145-
function _g_(ic){return cont([0, ic, 7]);}
145+
function _h_(ic){return cont([0, ic, 7]);}
146146
return b
147-
? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _g_)
148-
: caml_trampoline_cps_call2(Stdlib[79], cst_titi, _g_);
147+
? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _h_)
148+
: caml_trampoline_cps_call2(Stdlib[79], cst_titi, _h_);
149149
}
150150
//end
151151
function cond2(b, cont){
152-
function _g_(_g_){return cont(7);}
152+
function _h_(_h_){return cont(7);}
153153
return b
154-
? caml_trampoline_cps_call2(Stdlib_Printf[3], _a_, _g_)
155-
: caml_trampoline_cps_call2(Stdlib_Printf[3], _b_, _g_);
154+
? caml_trampoline_cps_call2(Stdlib_Printf[3], _a_, _h_)
155+
: caml_trampoline_cps_call2(Stdlib_Printf[3], _b_, _h_);
156156
}
157157
//end
158158
function cond3(b, cont){
159-
var x = [0, 0];
160-
function _g_(_g_){return cont(x[1]);}
159+
function _g_(x){return cont(x);}
160+
var x = 0;
161161
return b
162-
? (x[1] = 1, _g_(0))
163-
: caml_trampoline_cps_call2(Stdlib_Printf[3], _c_, _g_);
162+
? _g_(1)
163+
: caml_trampoline_cps_call2
164+
(Stdlib_Printf[3], _c_, function(_h_){return _g_(x);});
164165
}
165166
//end
166167
function loop1(b, cont){

0 commit comments

Comments
 (0)