Skip to content

Commit 44e20f7

Browse files
vouillonhhugo
vouillon
and
hhugo
authored
Compiler: improved compilation of switches (#1921)
Co-authored-by: Hugo Heuzard <[email protected]>
1 parent 7303d6c commit 44e20f7

File tree

9 files changed

+272
-9
lines changed

9 files changed

+272
-9
lines changed

‎CHANGES.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
* Misc: drop support for OCaml 4.12 and bellow
55
* Compiler: use a Wasm text files preprocessor (#1822)
66
* Compiler: support for OCaml 4.14.3+trunk (#1844)
7+
* Compiler: optimize compilation of switches
78
* Runtime: use es6 class (#1840)
89
* Runtime: support more Unix functions (#1829)
910
* Runtime: remove polyfill for Map to simplify MlObjectTable implementation (#1846)

‎compiler/lib/driver.ml‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -693,7 +693,8 @@ let optimize ~profile p =
693693
Code.Var.fresh_n "dummy"
694694
in
695695
let opt =
696-
specialize_js_once
696+
Specialize.switches
697+
+> specialize_js_once
697698
+> (match profile with
698699
| O1 -> o1
699700
| O2 -> o2

‎compiler/lib/eval.ml‎

Lines changed: 53 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,7 @@ let eval_prim x =
8585
| Le, [ Int i; Int j ] -> bool Targetint.(i <= j)
8686
| Eq, [ Int i; Int j ] -> bool Targetint.(i = j)
8787
| Neq, [ Int i; Int j ] -> bool Targetint.(i <> j)
88-
| Ult, [ Int i; Int j ] -> bool (Targetint.(j < zero) || Targetint.(i < j))
88+
| Ult, [ Int i; Int j ] -> bool (Targetint.unsigned_lt i j)
8989
| Extern name, l -> (
9090
let name = Primitive.resolve name in
9191
match name, l with
@@ -246,6 +246,33 @@ let the_cont_of info x (a : cont array) =
246246
| _ -> None)
247247
x
248248

249+
let rec int_predicate deep info pred x (i : Targetint.t) =
250+
if deep > 2
251+
then None
252+
else
253+
(* The value of [x] might be meaningless when we're inside a dead code.
254+
The proper fix would be to remove the deadcode entirely.
255+
Meanwhile, add guards to prevent Invalid_argument("index out of bounds")
256+
see https://github.com/ocsigen/js_of_ocaml/issues/485 *)
257+
get_approx
258+
info
259+
(fun x ->
260+
match Flow.Info.def info x with
261+
| Some (Prim (Extern "%direct_obj_tag", [ b ])) ->
262+
the_tag_of info b (fun j -> Some (pred (Targetint.of_int_exn j) i))
263+
| Some (Prim (Extern "%int_sub", [ Pv a; Pc (Int b) ])) ->
264+
int_predicate (deep + 1) info (fun x y -> pred (Targetint.sub x b) y) a i
265+
| Some (Prim (Extern "%int_add", [ Pv a; Pc (Int b) ])) ->
266+
int_predicate (deep + 1) info (fun x y -> pred (Targetint.add x b) y) a i
267+
| Some (Constant (Int j)) -> Some (pred j i)
268+
| None | Some _ -> None)
269+
None
270+
(fun u v ->
271+
match u, v with
272+
| Some i, Some j when Bool.equal i j -> u
273+
| _ -> None)
274+
x
275+
249276
(* If [constant_js_equal a b = Some v], then [caml_js_equals a b = v]). *)
250277
let constant_js_equal a b =
251278
match a, b with
@@ -333,6 +360,31 @@ let eval_instr ~target info i =
333360
let c = Constant (bool' Poly.(b = Y)) in
334361
Flow.Info.update_def info x c;
335362
[ Let (x, c) ])
363+
| Let
364+
( x
365+
, Prim
366+
( ((Eq | Neq | Lt | Le | Ult) as prim)
367+
, ([ (Pv y as fst); Pc (Int j) ] | [ (Pc (Int j) as fst); Pv y ]) ) ) -> (
368+
let pred =
369+
match prim with
370+
| Eq -> fun a b -> Targetint.equal a b
371+
| Neq -> fun a b -> not (Targetint.equal a b)
372+
| Lt -> fun a b -> Targetint.( < ) a b
373+
| Le -> fun a b -> Targetint.( <= ) a b
374+
| Ult -> fun a b -> Targetint.unsigned_lt a b
375+
| _ -> assert false
376+
in
377+
let pred =
378+
match fst with
379+
| Pv _ -> pred
380+
| Pc _ -> fun a b -> pred b a
381+
in
382+
match int_predicate 0 info pred y j with
383+
| Some b ->
384+
let c = Constant (bool' b) in
385+
Flow.Info.update_def info x c;
386+
[ Let (x, c) ]
387+
| None -> [ i ])
336388
| Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (
337389
match the_tag_of info y (fun x -> Some x) with
338390
| Some tag ->

‎compiler/lib/generate.ml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1120,7 +1120,7 @@ let _ =
11201120
register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc ->
11211121
let s = J.EBin (J.Plus, str_js_utf8 "", cx) in
11221122
ocaml_string ~ctx ~loc s);
1123-
register_un_prim "%direct_obj_tag" `Mutator (fun cx _loc -> Mlvalue.Block.tag cx);
1123+
register_un_prim "%direct_obj_tag" `Pure (fun cx _loc -> Mlvalue.Block.tag cx);
11241124
register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ ->
11251125
Mlvalue.Array.field cx cy);
11261126
register_bin_prim "%int_add" `Pure (fun cx cy _ ->

‎compiler/lib/specialize.ml‎

Lines changed: 94 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -117,3 +117,97 @@ let specialize_instrs ~function_arity p =
117117
{ p with blocks; free_pc }
118118

119119
let f = specialize_instrs
120+
121+
(***)
122+
123+
(* For switches, at this point, we know that this it is sufficient to
124+
check the [pc]. *)
125+
let equal (pc, _) (pc', _) = pc = pc'
126+
127+
let find_outlier_index arr =
128+
let len = Array.length arr in
129+
let rec find w i =
130+
if i >= len
131+
then `All_equals
132+
else if equal arr.(i) w
133+
then find w (i + 1)
134+
else `Distinguished i
135+
in
136+
let a0 = arr.(0) in
137+
match find a0 0 with
138+
| `All_equals as res -> res
139+
| `Distinguished i -> (
140+
match find arr.(i) i with
141+
| `All_equals ->
142+
if i = 1
143+
then `Distinguished 0
144+
else if i = len - 1
145+
then `Distinguished i
146+
else `Splitted i
147+
| `Distinguished j -> (
148+
match find a0 j with
149+
| `All_equals -> if j = i + 1 then `Distinguished i else `Splitted_shifted (i, j)
150+
| `Distinguished _ -> `Many_cases))
151+
152+
let switches p =
153+
{ p with
154+
blocks =
155+
Addr.Map.fold
156+
(fun pc block blocks ->
157+
match block.branch with
158+
| Switch (x, l) -> (
159+
match find_outlier_index l with
160+
| `All_equals -> Addr.Map.add pc { block with branch = Branch l.(0) } blocks
161+
| `Distinguished i ->
162+
let block =
163+
let c = Var.fresh () in
164+
{ block with
165+
body =
166+
block.body
167+
@ [ Let (c, Prim (Eq, [ Pc (Int (Targetint.of_int_exn i)); Pv x ]))
168+
]
169+
; branch = Cond (c, l.(i), l.((i + 1) mod Array.length l))
170+
}
171+
in
172+
Addr.Map.add pc block blocks
173+
| `Splitted i ->
174+
let block =
175+
let c = Var.fresh () in
176+
{ block with
177+
body =
178+
block.body
179+
@ [ Let (c, Prim (Lt, [ Pv x; Pc (Int (Targetint.of_int_exn i)) ]))
180+
]
181+
; branch = Cond (c, l.(i - 1), l.(i))
182+
}
183+
in
184+
Addr.Map.add pc block blocks
185+
| `Splitted_shifted (i, j) ->
186+
let block =
187+
let shifted = Var.fresh () in
188+
let c = Var.fresh () in
189+
{ block with
190+
body =
191+
block.body
192+
@ [ Let
193+
( shifted
194+
, Prim
195+
( Extern "%int_sub"
196+
, [ Pv x; Pc (Int (Targetint.of_int_exn i)) ] ) )
197+
; Let
198+
( c
199+
, Prim
200+
( Ult
201+
, [ Pv shifted
202+
; Pc (Int (Targetint.of_int_exn (j - i)))
203+
] ) )
204+
]
205+
; branch = Cond (c, l.(i), l.(j))
206+
}
207+
in
208+
Addr.Map.add pc block blocks
209+
| `Many_cases -> blocks)
210+
| _ -> blocks)
211+
p.blocks
212+
p.blocks
213+
}

‎compiler/lib/specialize.mli‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,3 +21,5 @@
2121
val function_arity : Flow.Info.t -> Code.Var.t -> int option
2222

2323
val f : function_arity:(Code.Var.t -> int option) -> Code.program -> Code.program
24+
25+
val switches : Code.program -> Code.program

‎compiler/lib/targetint.ml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -164,3 +164,5 @@ external ( = ) : int32 -> int32 -> bool = "%equal"
164164
external ( > ) : int32 -> int32 -> bool = "%greaterthan"
165165

166166
external ( >= ) : int32 -> int32 -> bool = "%greaterequal"
167+
168+
let unsigned_lt n m = Int32.(sub n min_int < sub m min_int)

‎compiler/lib/targetint.mli‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,3 +93,5 @@ val ( > ) : t -> t -> bool
9393
val ( = ) : t -> t -> bool
9494

9595
val ( <> ) : t -> t -> bool
96+
97+
val unsigned_lt : t -> t -> bool

‎compiler/tests-compiler/static_eval.ml‎

Lines changed: 115 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -159,7 +159,7 @@ let%expect_test "static eval of string get" =
159159
}
160160
//end |}]
161161

162-
let%expect_test "static eval of tags" =
162+
let%expect_test "static eval of tags (optimized switch)" =
163163
let program =
164164
compile_and_parse
165165
{|
@@ -191,11 +191,54 @@ let%expect_test "static eval of tags" =
191191
}
192192
var
193193
global_data = runtime.caml_get_global_data(),
194-
Stdlib_Random = global_data.Stdlib__Random,
195-
_a_ = [0, [1, 0]],
196-
_b_ = [1, 0],
197-
x = 1 < caml_call1(Stdlib_Random[5], 3) ? _a_ : _b_;
198-
x[0];
194+
Stdlib_Random = global_data.Stdlib__Random;
195+
1 < caml_call1(Stdlib_Random[5], 3);
196+
var
197+
foobar = 3,
198+
export$0 = [0, foobar, foobar],
199+
Test = [0, foobar, export$0];
200+
runtime.caml_register_global(3, Test, "Test");
201+
return;
202+
}
203+
(globalThis));
204+
//end
205+
|}]
206+
207+
let%expect_test "static eval of tags" =
208+
let program =
209+
compile_and_parse
210+
{|
211+
212+
type t = A | B | C of t | D of t | E of t | F of t
213+
214+
let foobar =
215+
let x = if Random.int 3 > 1 then C (D A) else D (A) in
216+
match x with
217+
| A -> 1
218+
| B -> 2
219+
| C _
220+
| D _ -> 3
221+
| E _ -> 5
222+
| F _ -> 7
223+
224+
let export = [|foobar;foobar|]
225+
|}
226+
in
227+
print_program program;
228+
[%expect
229+
{|
230+
(function(globalThis){
231+
"use strict";
232+
var runtime = globalThis.jsoo_runtime;
233+
function caml_call1(f, a0){
234+
return (f.l >= 0 ? f.l : f.l = f.length) === 1
235+
? f(a0)
236+
: runtime.caml_call_gen(f, [a0]);
237+
}
238+
var
239+
global_data = runtime.caml_get_global_data(),
240+
Stdlib_Random = global_data.Stdlib__Random;
241+
1 < caml_call1(Stdlib_Random[5], 3);
199242
var
200243
foobar = 3,
201244
export$0 = [0, foobar, foobar],
@@ -206,3 +249,69 @@ let%expect_test "static eval of tags" =
206249
(globalThis));
207250
//end
208251
|}]
252+
253+
let%expect_test "static eval int prims" =
254+
let program =
255+
compile_and_parse
256+
{|
257+
258+
let lt =
259+
let x = if Random.int 3 > 1 then 1 else 2 in
260+
x < 5
261+
262+
let le =
263+
let x = if Random.int 3 > 1 then 1 else 2 in
264+
x <= 5
265+
266+
let eq =
267+
let x = if Random.int 3 > 1 then 1 else 2 in
268+
x = 3
269+
270+
let neq =
271+
let x = if Random.int 3 > 1 then 1 else 2 in
272+
x <> 3
273+
274+
type ult = A | B | C | D
275+
276+
let ult =
277+
let x = if Random.int 3 > 1 then A else D in
278+
match x with
279+
| A | D -> true
280+
| B | C -> false
281+
282+
let export = [| lt; le; eq; neq; ult |]
283+
|}
284+
in
285+
print_program program;
286+
[%expect
287+
{|
288+
(function(globalThis){
289+
"use strict";
290+
var runtime = globalThis.jsoo_runtime;
291+
function caml_call1(f, a0){
292+
return (f.l >= 0 ? f.l : f.l = f.length) === 1
293+
? f(a0)
294+
: runtime.caml_call_gen(f, [a0]);
295+
}
296+
var
297+
global_data = runtime.caml_get_global_data(),
298+
Stdlib_Random = global_data.Stdlib__Random;
299+
1 < caml_call1(Stdlib_Random[5], 3);
300+
var lt = 1;
301+
1 < caml_call1(Stdlib_Random[5], 3);
302+
var le = 1;
303+
1 < caml_call1(Stdlib_Random[5], 3);
304+
var eq = 0;
305+
1 < caml_call1(Stdlib_Random[5], 3);
306+
var neq = 1;
307+
1 < caml_call1(Stdlib_Random[5], 3);
308+
var
309+
ult = 1,
310+
export$0 = [0, lt, le, eq, neq, ult],
311+
Test = [0, lt, le, eq, neq, ult, export$0];
312+
runtime.caml_register_global(1, Test, "Test");
313+
return;
314+
}
315+
(globalThis));
316+
//end
317+
|}]

0 commit comments

Comments
 (0)