Skip to content

Commit e8cea31

Browse files
vouillonvouillon
committed
WIP
1 parent cda0185 commit e8cea31

File tree

6 files changed

+227
-21
lines changed

6 files changed

+227
-21
lines changed

‎compiler/lib-wasm/call_graph_analysis.ml‎

Lines changed: 120 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,116 @@ type t = { unambiguous_non_escaping : unit Var.Hashtbl.t }
4242
let direct_calls_only info f =
4343
Config.Flag.optcall () && Var.Hashtbl.mem info.unambiguous_non_escaping f
4444

45+
let call_graph p info call_info =
46+
let under_handler = Var.Hashtbl.create 16 in
47+
let callees = Var.Hashtbl.create 16 in
48+
let callers = Var.Hashtbl.create 16 in
49+
let rec traverse name_opt pc visited nesting =
50+
if not (Addr.Set.mem pc visited)
51+
then (
52+
let visited = Addr.Set.add pc visited in
53+
let block = Addr.Map.find pc p.blocks in
54+
List.iter block.body ~f:(fun i ->
55+
match i with
56+
| Let (_, Apply { f; exact; _ }) -> (
57+
match get_approx info f with
58+
| Top -> ()
59+
| Values { known; others } ->
60+
if
61+
exact
62+
&& (not others)
63+
&& Var.Set.for_all (fun f -> direct_calls_only call_info f) known
64+
then
65+
if nesting > 0
66+
then
67+
Var.Set.iter
68+
(fun f ->
69+
(* Format.eprintf "BBB %a@." Code.Var.print f; *)
70+
Var.Hashtbl.replace under_handler f ())
71+
known
72+
else
73+
Option.iter
74+
~f:(fun f ->
75+
Var.Set.iter
76+
(fun g ->
77+
Var.Hashtbl.add callees f g;
78+
Var.Hashtbl.add callers g f)
79+
known)
80+
name_opt)
81+
| Let (_, (Closure _ | Prim _ | Block _ | Constant _ | Field _ | Special _))
82+
| Event _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ());
83+
Code.fold_children
84+
p.blocks
85+
pc
86+
(fun pc' visited ->
87+
let nesting =
88+
match block.branch with
89+
| Pushtrap ((body_pc, _), _, _) when pc' = body_pc -> nesting + 1
90+
| Poptrap _ -> nesting - 1
91+
| _ -> nesting
92+
in
93+
traverse name_opt pc' visited nesting)
94+
visited)
95+
else visited
96+
in
97+
fold_closures
98+
p
99+
(fun name_opt _ (pc, _) _ () -> ignore (traverse name_opt pc Addr.Set.empty 0))
100+
();
101+
under_handler, callers, callees
102+
103+
let function_do_raise p pc =
104+
Code.traverse
105+
{ fold = Code.fold_children_skip_try_body }
106+
(fun pc do_raise ->
107+
let block = Addr.Map.find pc p.blocks in
108+
do_raise
109+
||
110+
match block.branch with
111+
| Raise _ -> true
112+
| _ -> false)
113+
pc
114+
p.blocks
115+
false
116+
117+
let propagate nodes edges eligible =
118+
let rec propagate n =
119+
List.iter
120+
~f:(fun n' ->
121+
if (not (Var.Hashtbl.mem nodes n')) && eligible n'
122+
then (
123+
Var.Hashtbl.add nodes n' ();
124+
propagate n'))
125+
(Var.Hashtbl.find_all edges n)
126+
in
127+
Var.Hashtbl.iter (fun n () -> propagate n) nodes
128+
129+
let raising_functions p info call_info eligible =
130+
let under_handler, callers, callees = call_graph p info call_info in
131+
propagate under_handler callees eligible;
132+
let h = Var.Hashtbl.create 16 in
133+
Code.fold_closures
134+
p
135+
(fun name_opt _params (pc, _) _ () ->
136+
match name_opt with
137+
| None -> ()
138+
| Some name ->
139+
if
140+
direct_calls_only call_info name
141+
&& eligible name
142+
&& function_do_raise p pc
143+
&& Var.Hashtbl.mem under_handler name
144+
then Var.Hashtbl.add h name ())
145+
();
146+
propagate h callers (fun f -> eligible f && Var.Hashtbl.mem under_handler f);
147+
if false
148+
then
149+
Var.Hashtbl.iter
150+
(fun name () ->
151+
Format.eprintf "ZZZ %a %b@." Var.print name (Var.Hashtbl.mem under_handler name))
152+
h;
153+
h
154+
45155
let f p info =
46156
let t = Timer.make () in
47157
let non_escaping = Var.Hashtbl.create 128 in
@@ -62,4 +172,13 @@ let f p info =
62172
if debug ()
63173
then Format.eprintf " unambiguous-non-escaping:%d@." (Var.Hashtbl.length non_escaping);
64174
if times () then Format.eprintf " call graph analysis: %a@." Timer.print t;
65-
{ unambiguous_non_escaping = non_escaping }
175+
(*
176+
Var.Hashtbl.iter (fun f _ -> Format.eprintf "AAA %a@." Code.Var.print f) non_escaping;
177+
*)
178+
let call_info = { unambiguous_non_escaping = non_escaping } in
179+
call_info
180+
181+
(*
182+
- Optimize tail-calls
183+
- Cannot change calling convention if the function has tail-calls
184+
*)

‎compiler/lib-wasm/call_graph_analysis.mli‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,4 +2,7 @@ type t
22

33
val direct_calls_only : t -> Code.Var.t -> bool
44

5+
val raising_functions :
6+
Code.program -> Global_flow.info -> t -> (Code.Var.t -> bool) -> unit Code.Var.Hashtbl.t
7+
58
val f : Code.program -> Global_flow.info -> t

‎compiler/lib-wasm/gc_target.ml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,8 @@ type expression = Wasm_ast.expression Code_generation.t
2525
module Type = struct
2626
let value = W.Ref { nullable = false; typ = Eq }
2727

28+
let value_or_exn = W.Ref { nullable = true; typ = Eq }
29+
2830
let block_type =
2931
register_type "block" (fun () ->
3032
return

‎compiler/lib-wasm/generate.ml‎

Lines changed: 98 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ module Generate (Target : Target_sig.S) = struct
3838
; global_flow_info : Global_flow.info
3939
; fun_info : Call_graph_analysis.t
4040
; types : Typing.t
41+
; raising_funcs : unit Var.Hashtbl.t
4142
; blocks : block Addr.Map.t
4243
; closures : Closure_conversion.closure Var.Map.t
4344
; global_context : Code_generation.context
@@ -1342,6 +1343,19 @@ module Generate (Target : Target_sig.S) = struct
13421343
| Number (n, Boxed) as into -> convert ~from:(Number (n, Unboxed)) ~into e
13431344
| _ -> e
13441345

1346+
let exception_handler_pc = -3
1347+
1348+
let direct_call ctx context f args closure =
1349+
let e = W.Call (f, args @ [ closure ]) in
1350+
let e =
1351+
if Var.Hashtbl.mem ctx.raising_funcs f
1352+
then
1353+
let label = label_index context exception_handler_pc in
1354+
W.Br_on_null (label, e)
1355+
else e
1356+
in
1357+
return e
1358+
13451359
let rec translate_expr ctx context x e =
13461360
match e with
13471361
| Apply { f; args; exact; _ } ->
@@ -1375,7 +1389,7 @@ module Generate (Target : Target_sig.S) = struct
13751389
convert
13761390
~from:(Typing.return_type ctx.types g)
13771391
~into:(Typing.var_type ctx.types x)
1378-
(return (W.Call (g, args @ [ cl ])))
1392+
(direct_call ctx context g args cl)
13791393
| None -> (
13801394
let funct = Var.fresh () in
13811395
let* closure = tee funct (return closure) in
@@ -1387,7 +1401,7 @@ module Generate (Target : Target_sig.S) = struct
13871401
in
13881402
let* args = expression_list (fun x -> load_and_box ctx x) args in
13891403
match funct with
1390-
| W.RefFunc g -> return (W.Call (g, args @ [ closure ]))
1404+
| W.RefFunc g -> direct_call ctx context g args closure
13911405
| _ -> return (W.Call_ref (ty, funct, args @ [ closure ])))
13921406
else
13931407
let* apply =
@@ -1694,25 +1708,47 @@ module Generate (Target : Target_sig.S) = struct
16941708
instr W.Unreachable
16951709
else body ~result_typ ~fall_through ~context
16961710

1697-
let wrap_with_handlers p pc ~result_typ ~fall_through ~context body =
1711+
let wrap_with_handlers ~location p pc ~result_typ ~fall_through ~context body =
16981712
let need_zero_divide_handler, need_bound_error_handler = needed_handlers p pc in
16991713
wrap_with_handler
1700-
need_bound_error_handler
1701-
bound_error_pc
1702-
(let* f =
1703-
register_import ~name:"caml_bound_error" (Fun { params = []; result = [] })
1704-
in
1705-
instr (CallInstr (f, [])))
1714+
true
1715+
exception_handler_pc
1716+
(match location with
1717+
| `Toplevel ->
1718+
let* exn =
1719+
register_import
1720+
~import_module:"env"
1721+
~name:"caml_exception"
1722+
(Global { mut = true; typ = Type.value })
1723+
in
1724+
let* tag = register_import ~name:exception_name (Tag Type.value) in
1725+
instr (Throw (tag, GlobalGet exn))
1726+
| `Exception_handler ->
1727+
let* exn =
1728+
register_import
1729+
~import_module:"env"
1730+
~name:"caml_exception"
1731+
(Global { mut = true; typ = Type.value })
1732+
in
1733+
instr (Br (2, Some (GlobalGet exn)))
1734+
| `Function -> instr (Return (Some (RefNull Any))))
17061735
(wrap_with_handler
1707-
need_zero_divide_handler
1708-
zero_divide_pc
1736+
need_bound_error_handler
1737+
bound_error_pc
17091738
(let* f =
1710-
register_import
1711-
~name:"caml_raise_zero_divide"
1712-
(Fun { params = []; result = [] })
1739+
register_import ~name:"caml_bound_error" (Fun { params = []; result = [] })
17131740
in
17141741
instr (CallInstr (f, [])))
1715-
body)
1742+
(wrap_with_handler
1743+
need_zero_divide_handler
1744+
zero_divide_pc
1745+
(let* f =
1746+
register_import
1747+
~name:"caml_raise_zero_divide"
1748+
(Fun { params = []; result = [] })
1749+
in
1750+
instr (CallInstr (f, [])))
1751+
body))
17161752
~result_typ
17171753
~fall_through
17181754
~context
@@ -1732,6 +1768,11 @@ module Generate (Target : Target_sig.S) = struct
17321768
| Some f -> Typing.return_type ctx.types f
17331769
| _ -> Typing.Top
17341770
in
1771+
let return_exn =
1772+
match name_opt with
1773+
| Some f -> Var.Hashtbl.mem ctx.raising_funcs f
1774+
| _ -> false
1775+
in
17351776
let g = Structure.build_graph ctx.blocks pc in
17361777
let dom = Structure.dominator_tree g in
17371778
let rec translate_tree result_typ fall_through pc context =
@@ -1830,19 +1871,34 @@ module Generate (Target : Target_sig.S) = struct
18301871
instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1)))
18311872
| Raise (x, _) -> (
18321873
let* e = load x in
1833-
let* tag = register_import ~name:exception_name (Tag Type.value) in
18341874
match fall_through with
18351875
| `Catch -> instr (Push e)
18361876
| `Block _ | `Return | `Skip -> (
18371877
match catch_index context with
18381878
| Some i -> instr (Br (i, Some e))
1839-
| None -> instr (Throw (tag, e))))
1879+
| None ->
1880+
if return_exn
1881+
then
1882+
let* exn =
1883+
register_import
1884+
~import_module:"env"
1885+
~name:"caml_exception"
1886+
(Global { mut = true; typ = Type.value })
1887+
in
1888+
let* () = instr (GlobalSet (exn, e)) in
1889+
instr (Return (Some (RefNull Any)))
1890+
else
1891+
let* tag =
1892+
register_import ~name:exception_name (Tag Type.value)
1893+
in
1894+
instr (Throw (tag, e))))
18401895
| Pushtrap (cont, x, cont') ->
18411896
handle_exceptions
18421897
~result_typ
18431898
~fall_through
18441899
~context:(extend_context fall_through context)
18451900
(wrap_with_handlers
1901+
~location:`Exception_handler
18461902
p
18471903
(fst cont)
18481904
(fun ~result_typ ~fall_through ~context ->
@@ -1914,6 +1970,7 @@ module Generate (Target : Target_sig.S) = struct
19141970
let* () = build_initial_env in
19151971
let* () =
19161972
wrap_with_handlers
1973+
~location:(if return_exn then `Function else `Toplevel)
19171974
p
19181975
pc
19191976
~result_typ:[ Option.value ~default:Type.value (unboxed_type return_type) ]
@@ -1951,7 +2008,11 @@ module Generate (Target : Target_sig.S) = struct
19512008
(unboxed_type (Typing.var_type ctx.types x)))
19522009
params
19532010
@ [ Type.value ]
1954-
; result = [ Option.value ~default:Type.value (unboxed_type return_type) ]
2011+
; result =
2012+
[ Option.value
2013+
~default:(if return_exn then Type.value_or_exn else Type.value)
2014+
(unboxed_type return_type)
2015+
]
19552016
}
19562017
else Type.func_type (param_count - 1))
19572018
; param_names
@@ -2026,7 +2087,8 @@ module Generate (Target : Target_sig.S) = struct
20262087
*)
20272088
~global_flow_info
20282089
~fun_info
2029-
~types =
2090+
~types
2091+
~raising_funcs =
20302092
global_context.unit_name <- unit_name;
20312093
let p, closures = Closure_conversion.f p in
20322094
(*
@@ -2038,6 +2100,7 @@ module Generate (Target : Target_sig.S) = struct
20382100
; global_flow_info
20392101
; fun_info
20402102
; types
2103+
; raising_funcs
20412104
; blocks = p.blocks
20422105
; closures
20432106
; global_context
@@ -2150,11 +2213,26 @@ let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~global_flow_d
21502213
let types =
21512214
Typing.f ~global_flow_state ~global_flow_info ~fun_info ~deadcode_sentinal p
21522215
in
2216+
let raising_funcs =
2217+
Call_graph_analysis.raising_functions p global_flow_info fun_info (fun f ->
2218+
match Typing.return_type types f with
2219+
| Int (Normalized | Unnormalized) | Number (_, Unboxed) -> false
2220+
| Int Ref | Number (_, Boxed) | Top | Bot | Tuple _ | Bigarray _ -> true)
2221+
in
21532222
let t = Timer.make () in
21542223
let p = Structure.norm p in
21552224
let p = fix_switch_branches p in
21562225
let res =
2157-
G.f ~context ~unit_name ~live_vars ~in_cps ~global_flow_info ~fun_info ~types p
2226+
G.f
2227+
~context
2228+
~unit_name
2229+
~live_vars
2230+
~in_cps
2231+
~global_flow_info
2232+
~fun_info
2233+
~types
2234+
~raising_funcs
2235+
p
21582236
in
21592237
if times () then Format.eprintf " code gen.: %a@." Timer.print t;
21602238
res

‎compiler/lib-wasm/target_sig.ml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,8 @@ module type S = sig
9797
module Type : sig
9898
val value : Wasm_ast.value_type
9999

100+
val value_or_exn : Wasm_ast.value_type
101+
100102
val func_type : int -> Wasm_ast.func_type
101103

102104
val primitive_type : int -> Wasm_ast.func_type

‎runtime/wasm/stdlib.wat‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -234,4 +234,6 @@
234234
(call $unwrap
235235
(call $caml_jsstring_of_string (local.get $msg)))))
236236
(call $exit (i32.const 2)))))
237+
238+
(global (export "caml_exception") (mut (ref eq)) (ref.i31 (i32.const 0)))
237239
)

0 commit comments

Comments
 (0)