@@ -163,8 +163,8 @@ let trans_visitor
163
163
let emitters = Stack. create () in
164
164
let push_new_emitter (vregs_ok :bool ) (fnid :node_id option ) =
165
165
let e = Il. new_emitter
166
- abi.Abi. abi_emit_target_specific
167
- vregs_ok fnid
166
+ abi.Abi. abi_emit_target_specific
167
+ vregs_ok fnid
168
168
in
169
169
Stack. push e emitters;
170
170
in
@@ -179,13 +179,54 @@ let trans_visitor
179
179
Hashtbl. clear (emitter_size_cache() )
180
180
in
181
181
182
+ let quad_categories = Hashtbl. create 0 in
183
+ let quad_category_stack = Stack. create () in
184
+ let in_quad_category name thunk =
185
+ if cx.ctxt_sess.Session. sess_report_quads
186
+ then Stack. push name quad_category_stack;
187
+ let x = thunk() in
188
+ if cx.ctxt_sess.Session. sess_report_quads
189
+ then ignore (Stack. pop quad_category_stack);
190
+ x
191
+ in
192
+
193
+ let credit name i =
194
+ let c =
195
+ htab_search_or_add quad_categories name
196
+ (fun _ -> ref 0 )
197
+ in
198
+ c := (! c) + i
199
+ in
200
+
201
+ let in_native_quad_category name thunk =
202
+ if cx.ctxt_sess.Session. sess_report_quads
203
+ then
204
+ let i = (emitter() ).Il. emit_pc in
205
+ let x = thunk() in
206
+ let j = (emitter() ).Il. emit_pc in
207
+ credit name (j- i);
208
+ x
209
+ else
210
+ thunk()
211
+ in
212
+
182
213
let emit q =
183
214
begin
184
215
match q with
185
216
Il. Jmp _ -> flush_emitter_size_cache() ;
186
217
| _ -> ()
187
218
end ;
188
- Il. emit (emitter() ) q
219
+ Il. emit (emitter() ) q;
220
+ if cx.ctxt_sess.Session. sess_report_quads
221
+ then
222
+ begin
223
+ let name =
224
+ if Stack. is_empty quad_category_stack
225
+ then " other"
226
+ else Stack. top quad_category_stack
227
+ in
228
+ credit name 1
229
+ end
189
230
in
190
231
191
232
let next_vreg _ = Il. next_vreg (emitter() ) in
@@ -2517,15 +2558,19 @@ let trans_visitor
2517
2558
(ret :Il.cell )
2518
2559
(args :Il.operand array )
2519
2560
: unit =
2520
- abi.Abi. abi_emit_native_call (emitter() )
2521
- ret nabi_rust (upcall_fixup name) args;
2561
+ in_native_quad_category " upcall"
2562
+ (fun _ ->
2563
+ abi.Abi. abi_emit_native_call (emitter() )
2564
+ ret nabi_rust (upcall_fixup name) args)
2522
2565
2523
2566
and trans_void_upcall
2524
2567
(name :string )
2525
2568
(args :Il.operand array )
2526
2569
: unit =
2527
- abi.Abi. abi_emit_native_void_call (emitter() )
2528
- nabi_rust (upcall_fixup name) args;
2570
+ in_native_quad_category " upcall"
2571
+ (fun _ ->
2572
+ abi.Abi. abi_emit_native_void_call (emitter() )
2573
+ nabi_rust (upcall_fixup name) args);
2529
2574
2530
2575
and trans_log_int (a :Ast.atom ) : unit =
2531
2576
trans_void_upcall " upcall_log_int" [| (trans_atom a) |]
@@ -4705,7 +4750,8 @@ let trans_visitor
4705
4750
annotate s;
4706
4751
end;
4707
4752
Stack. push stmt.id curr_stmt;
4708
- trans_stmt_full stmt;
4753
+ (in_quad_category " stmt"
4754
+ (fun _ -> trans_stmt_full stmt));
4709
4755
begin
4710
4756
match stmt.node with
4711
4757
Ast. STMT_be _
@@ -5834,6 +5880,24 @@ let trans_visitor
5834
5880
inner.Walk. visit_crate_pre crate
5835
5881
in
5836
5882
5883
+ let report_quads _ =
5884
+ if cx.ctxt_sess.Session. sess_report_quads
5885
+ then
5886
+ begin
5887
+ let cumulative = ref 0 in
5888
+ Printf. fprintf stdout " quads:\n\n " ;
5889
+ Array. iter
5890
+ begin
5891
+ fun name ->
5892
+ let t = Hashtbl. find quad_categories name in
5893
+ Printf. fprintf stdout " %20s: %d\n " name (! t);
5894
+ cumulative := (! cumulative) + (! t)
5895
+ end
5896
+ (sorted_htab_keys quad_categories);
5897
+ Printf. fprintf stdout " \n %20s: %d\n " " cumulative" (! cumulative)
5898
+ end
5899
+ in
5900
+
5837
5901
let visit_crate_post crate =
5838
5902
5839
5903
inner.Walk. visit_crate_post crate;
@@ -5921,7 +5985,9 @@ let trans_visitor
5921
5985
5922
5986
provide_existing_native cx SEG_data " rust_crate" cx.ctxt_crate_fixup;
5923
5987
5924
- leave_file_for crate.id
5988
+ leave_file_for crate.id;
5989
+
5990
+ report_quads()
5925
5991
in
5926
5992
5927
5993
{ inner with
0 commit comments