1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
15 (* Selection of pseudo-instructions, assignment of pseudo-registers,
23 type environment
= (Ident.t
, Reg.t array
) Tbl.t
25 (* Infer the type of the result of an operation *)
27 let oper_result_type = function
29 | Cextcall
(s
, ty
, alloc
, _
) -> ty
33 | Single
| Double
| Double_u
-> typ_float
37 | Cstore c
-> typ_void
38 | Caddi
| Csubi
| Cmuli
| Cdivi
| Cmodi
|
39 Cand
| Cor
| Cxor
| Clsl
| Clsr
| Casr
|
40 Ccmpi _
| Ccmpa _
| Ccmpf _
-> typ_int
41 | Cadda
| Csuba
-> typ_addr
42 | Cnegf
| Cabsf
| Caddf
| Csubf
| Cmulf
| Cdivf
-> typ_float
43 | Cfloatofint
-> typ_float
44 | Cintoffloat
-> typ_int
45 | Craise _
-> typ_void
46 | Ccheckbound _
-> typ_void
48 (* Infer the size in bytes of the result of a simple expression *)
50 let size_expr env exp
=
51 let rec size localenv
= function
52 Cconst_int _
| Cconst_natint _
-> Arch.size_int
53 | Cconst_symbol _
| Cconst_pointer _
| Cconst_natpointer _
->
55 | Cconst_float _
-> Arch.size_float
61 let regs = Tbl.find id env
in
62 size_machtype
(Array.map
(fun r
-> r
.typ
) regs)
64 fatal_error
("Selection.size_expr: unbound var " ^
68 List.fold_right
(fun e sz
-> size localenv e
+ sz
) el
0
70 size_machtype
(oper_result_type op
)
71 | Clet
(id
, arg
, body
) ->
72 size (Tbl.add id
(size localenv arg
) localenv
) body
73 | Csequence
(e1
, e2
) ->
76 fatal_error
"Selection.size_expr"
79 (* Swap the two arguments of an integer comparison *)
81 let swap_intcomp = function
82 Isigned cmp
-> Isigned
(swap_comparison cmp
)
83 | Iunsigned cmp
-> Iunsigned
(swap_comparison cmp
)
85 (* Naming of registers *)
87 let all_regs_anonymous rv
=
89 for i
= 0 to Array.length rv
- 1 do
90 if String.length rv
.(i
).name
> 0 then raise Exit
97 if Array.length rv
= 1 then
98 rv
.(0).name
<- Ident.name id
100 for i
= 0 to Array.length rv
- 1 do
101 rv
.(i
).name
<- Ident.name id ^
"#" ^ string_of_int i
104 (* "Join" two instruction sequences, making sure they return their results
105 in the same registers. *)
107 let join opt_r1 seq1 opt_r2 seq2
=
108 match (opt_r1
, opt_r2
) with
110 | (_
, None
) -> opt_r1
111 | (Some r1
, Some r2
) ->
112 let l1 = Array.length r1
in
113 assert (l1 = Array.length r2
);
114 let r = Array.create
l1 Reg.dummy
in
116 if String.length r1
.(i
).name
= 0 then begin
118 seq2#insert_move r2
.(i
) r1
.(i
)
119 end else if String.length r2
.(i
).name
= 0 then begin
121 seq1#insert_move r1
.(i
) r2
.(i
)
123 r.(i
) <- Reg.create r1
.(i
).typ
;
124 seq1#insert_move r1
.(i
) r.(i
);
125 seq2#insert_move r2
.(i
) r.(i
)
130 (* Same, for N branches *)
133 let some_res = ref None
in
134 for i
= 0 to Array.length rs
- 1 do
135 let (r, s
) = rs
.(i
) in
136 if r <> None
then some_res := r
141 let size_res = Array.length template
in
142 let res = Array.create
size_res Reg.dummy
in
143 for i
= 0 to size_res - 1 do
144 res.(i
) <- Reg.create template
.(i
).typ
146 for i
= 0 to Array.length rs
- 1 do
147 let (r, s
) = rs
.(i
) in
150 | Some
r -> s#insert_moves
r res
154 (* Extract debug info contained in a C-- operation *)
155 let debuginfo_op = function
156 | Capply
(_
, dbg
) -> dbg
157 | Cextcall
(_
, _
, _
, dbg
) -> dbg
159 | Ccheckbound dbg
-> dbg
160 | _
-> Debuginfo.none
162 (* Registers for catch constructs *)
163 let catch_regs = ref []
165 (* Name of function being compiled *)
166 let current_function_name = ref ""
168 (* The default instruction selection class *)
170 class virtual selector_generic
= object (self
)
172 (* Says if an expression is "simple". A "simple" expression has no
173 side-effects and its execution can be delayed until its value
174 is really needed. In the case of e.g. an [alloc] instruction,
175 the non-simple arguments are computed in right-to-left order
176 first, then the block is allocated, then the simple arguments are
177 evaluated and stored. *)
179 method is_simple_expr
= function
181 | Cconst_natint _
-> true
182 | Cconst_float _
-> true
183 | Cconst_symbol _
-> true
184 | Cconst_pointer _
-> true
185 | Cconst_natpointer _
-> true
187 | Ctuple el
-> List.for_all self#is_simple_expr el
188 | Clet
(id
, arg
, body
) -> self#is_simple_expr arg
&& self#is_simple_expr body
189 | Csequence
(e1
, e2
) -> self#is_simple_expr e1
&& self#is_simple_expr e2
192 (* The following may have side effects *)
193 | Capply _
| Cextcall _
| Calloc
| Cstore _
| Craise _
-> false
194 (* The remaining operations are simple if their args are *)
196 List.for_all self#is_simple_expr args
200 (* Says whether an integer constant is a suitable immediate argument *)
202 method virtual is_immediate
: int -> bool
204 (* Selection of addressing modes *)
206 method virtual select_addressing
:
207 Cmm.expression
-> Arch.addressing_mode
* Cmm.expression
209 (* Default instruction selection for stores (of words) *)
211 method select_store addr arg
=
212 (Istore
(Word
, addr
), arg
)
214 (* Default instruction selection for operators *)
216 method select_operation op args
=
217 match (op
, args
) with
218 (Capply
(ty
, dbg
), Cconst_symbol s
:: rem
) -> (Icall_imm s
, rem
)
219 | (Capply
(ty
, dbg
), _
) -> (Icall_ind
, args
)
220 | (Cextcall
(s
, ty
, alloc
, dbg
), _
) -> (Iextcall
(s
, alloc
), args
)
221 | (Cload chunk
, [arg
]) ->
222 let (addr
, eloc
) = self#select_addressing arg
in
223 (Iload
(chunk
, addr
), [eloc
])
224 | (Cstore chunk
, [arg1
; arg2
]) ->
225 let (addr
, eloc
) = self#select_addressing arg1
in
226 if chunk
= Word
then begin
227 let (op
, newarg2
) = self#select_store addr arg2
in
228 (op
, [newarg2
; eloc
])
230 (Istore
(chunk
, addr
), [arg2
; eloc
])
231 (* Inversion addr/datum in Istore *)
233 | (Calloc
, _
) -> (Ialloc
0, args
)
234 | (Caddi
, _
) -> self#select_arith_comm Iadd args
235 | (Csubi
, _
) -> self#select_arith Isub args
236 | (Cmuli
, [arg1
; Cconst_int n
]) ->
237 let l = Misc.log2 n
in
239 then (Iintop_imm
(Ilsl
, l), [arg1
])
240 else self#select_arith_comm Imul args
241 | (Cmuli
, [Cconst_int n
; arg1
]) ->
242 let l = Misc.log2 n
in
244 then (Iintop_imm
(Ilsl
, l), [arg1
])
245 else self#select_arith_comm Imul args
246 | (Cmuli
, _
) -> self#select_arith_comm Imul args
247 | (Cdivi
, _
) -> self#select_arith Idiv args
248 | (Cmodi
, _
) -> self#select_arith_comm Imod args
249 | (Cand
, _
) -> self#select_arith_comm Iand args
250 | (Cor
, _
) -> self#select_arith_comm Ior args
251 | (Cxor
, _
) -> self#select_arith_comm Ixor args
252 | (Clsl
, _
) -> self#select_shift Ilsl args
253 | (Clsr
, _
) -> self#select_shift Ilsr args
254 | (Casr
, _
) -> self#select_shift Iasr args
255 | (Ccmpi comp
, _
) -> self#select_arith_comp
(Isigned comp
) args
256 | (Cadda
, _
) -> self#select_arith_comm Iadd args
257 | (Csuba
, _
) -> self#select_arith Isub args
258 | (Ccmpa comp
, _
) -> self#select_arith_comp
(Iunsigned comp
) args
259 | (Cnegf
, _
) -> (Inegf
, args
)
260 | (Cabsf
, _
) -> (Iabsf
, args
)
261 | (Caddf
, _
) -> (Iaddf
, args
)
262 | (Csubf
, _
) -> (Isubf
, args
)
263 | (Cmulf
, _
) -> (Imulf
, args
)
264 | (Cdivf
, _
) -> (Idivf
, args
)
265 | (Cfloatofint
, _
) -> (Ifloatofint
, args
)
266 | (Cintoffloat
, _
) -> (Iintoffloat
, args
)
267 | (Ccheckbound _
, _
) -> self#select_arith Icheckbound args
268 | _
-> fatal_error
"Selection.select_oper"
270 method private select_arith_comm op
= function
271 [arg
; Cconst_int n
] when self#is_immediate n
->
272 (Iintop_imm
(op
, n
), [arg
])
273 | [arg
; Cconst_pointer n
] when self#is_immediate n
->
274 (Iintop_imm
(op
, n
), [arg
])
275 | [Cconst_int n
; arg
] when self#is_immediate n
->
276 (Iintop_imm
(op
, n
), [arg
])
277 | [Cconst_pointer n
; arg
] when self#is_immediate n
->
278 (Iintop_imm
(op
, n
), [arg
])
282 method private select_arith op
= function
283 [arg
; Cconst_int n
] when self#is_immediate n
->
284 (Iintop_imm
(op
, n
), [arg
])
285 | [arg
; Cconst_pointer n
] when self#is_immediate n
->
286 (Iintop_imm
(op
, n
), [arg
])
290 method private select_shift op
= function
291 [arg
; Cconst_int n
] when n
>= 0 && n
< Arch.size_int
* 8 ->
292 (Iintop_imm
(op
, n
), [arg
])
296 method private select_arith_comp cmp
= function
297 [arg
; Cconst_int n
] when self#is_immediate n
->
298 (Iintop_imm
(Icomp cmp
, n
), [arg
])
299 | [arg
; Cconst_pointer n
] when self#is_immediate n
->
300 (Iintop_imm
(Icomp cmp
, n
), [arg
])
301 | [Cconst_int n
; arg
] when self#is_immediate n
->
302 (Iintop_imm
(Icomp
(swap_intcomp cmp
), n
), [arg
])
303 | [Cconst_pointer n
; arg
] when self#is_immediate n
->
304 (Iintop_imm
(Icomp
(swap_intcomp cmp
), n
), [arg
])
306 (Iintop
(Icomp cmp
), args
)
308 (* Instruction selection for conditionals *)
310 method select_condition
= function
311 Cop
(Ccmpi cmp
, [arg1
; Cconst_int n
]) when self#is_immediate n
->
312 (Iinttest_imm
(Isigned cmp
, n
), arg1
)
313 | Cop
(Ccmpi cmp
, [Cconst_int n
; arg2
]) when self#is_immediate n
->
314 (Iinttest_imm
(Isigned
(swap_comparison cmp
), n
), arg2
)
315 | Cop
(Ccmpi cmp
, [arg1
; Cconst_pointer n
]) when self#is_immediate n
->
316 (Iinttest_imm
(Isigned cmp
, n
), arg1
)
317 | Cop
(Ccmpi cmp
, [Cconst_pointer n
; arg2
]) when self#is_immediate n
->
318 (Iinttest_imm
(Isigned
(swap_comparison cmp
), n
), arg2
)
319 | Cop
(Ccmpi cmp
, args
) ->
320 (Iinttest
(Isigned cmp
), Ctuple args
)
321 | Cop
(Ccmpa cmp
, [arg1
; Cconst_pointer n
]) when self#is_immediate n
->
322 (Iinttest_imm
(Iunsigned cmp
, n
), arg1
)
323 | Cop
(Ccmpa cmp
, [arg1
; Cconst_int n
]) when self#is_immediate n
->
324 (Iinttest_imm
(Iunsigned cmp
, n
), arg1
)
325 | Cop
(Ccmpa cmp
, [Cconst_pointer n
; arg2
]) when self#is_immediate n
->
326 (Iinttest_imm
(Iunsigned
(swap_comparison cmp
), n
), arg2
)
327 | Cop
(Ccmpa cmp
, [Cconst_int n
; arg2
]) when self#is_immediate n
->
328 (Iinttest_imm
(Iunsigned
(swap_comparison cmp
), n
), arg2
)
329 | Cop
(Ccmpa cmp
, args
) ->
330 (Iinttest
(Iunsigned cmp
), Ctuple args
)
331 | Cop
(Ccmpf cmp
, args
) ->
332 (Ifloattest
(cmp
, false), Ctuple args
)
333 | Cop
(Cand
, [arg
; Cconst_int
1]) ->
338 (* Buffering of instruction sequences *)
340 val mutable instr_seq
= dummy_instr
342 method insert_debug desc dbg arg
res =
343 instr_seq
<- instr_cons_debug desc arg
res dbg instr_seq
345 method insert desc arg
res =
346 instr_seq
<- instr_cons desc arg
res instr_seq
349 let rec extract res i
=
352 else extract {i
with next
= res} i
.next
in
353 extract (end_instr
()) instr_seq
355 (* Insert a sequence of moves from one pseudoreg set to another. *)
357 method insert_move src dst
=
358 if src
.stamp
<> dst
.stamp
then
359 self#insert
(Iop Imove
) [|src
|] [|dst
|]
361 method insert_moves src dst
=
362 for i
= 0 to Array.length src
- 1 do
363 self#insert_move src
.(i
) dst
.(i
)
366 (* Insert moves and stack offsets for function arguments and results *)
368 method insert_move_args arg loc stacksize
=
369 if stacksize
<> 0 then self#insert
(Iop
(Istackoffset stacksize
)) [||] [||];
370 self#insert_moves arg loc
372 method insert_move_results loc
res stacksize
=
373 if stacksize
<> 0 then self#insert
(Iop
(Istackoffset
(-stacksize
))) [||] [||];
374 self#insert_moves loc
res
376 (* Add an Iop opcode. Can be overriden by processor description
377 to insert moves before and after the operation, i.e. for two-address
378 instructions, or instructions using dedicated registers. *)
380 method insert_op_debug op dbg rs rd
=
381 self#insert_debug
(Iop op
) dbg rs rd
;
384 method insert_op op rs rd
=
385 self#insert
(Iop op
) rs rd
;
388 (* Add the instructions for the given expression
389 at the end of the self sequence *)
391 method emit_expr env exp
=
394 let r = Reg.createv typ_int
in
395 Some
(self#insert_op
(Iconst_int
(Nativeint.of_int n
)) [||] r)
397 let r = Reg.createv typ_int
in
398 Some
(self#insert_op
(Iconst_int n
) [||] r)
400 let r = Reg.createv typ_float
in
401 Some
(self#insert_op
(Iconst_float n
) [||] r)
403 let r = Reg.createv typ_addr
in
404 Some
(self#insert_op
(Iconst_symbol n
) [||] r)
405 | Cconst_pointer n
->
406 let r = Reg.createv typ_addr
in
407 Some
(self#insert_op
(Iconst_int
(Nativeint.of_int n
)) [||] r)
408 | Cconst_natpointer n
->
409 let r = Reg.createv typ_addr
in
410 Some
(self#insert_op
(Iconst_int n
) [||] r)
415 fatal_error
("Selection.emit_expr: unbound var " ^
Ident.unique_name v
)
418 begin match self#emit_expr env e1
with
420 | Some r1
-> self#emit_expr
(self#bind_let
env v r1
) e2
427 fatal_error
("Selection.emit_expr: unbound var " ^
Ident.name v
) in
428 begin match self#emit_expr
env e1
with
430 | Some r1
-> self#insert_moves r1
rv; Some
[||]
435 begin match self#emit_parts_list
env exp_list
with
437 | Some
(simple_list
, ext_env
) ->
438 Some
(self#emit_tuple ext_env simple_list
)
440 | Cop
(Craise dbg
, [arg
]) ->
441 begin match self#emit_expr
env arg
with
444 let rd = [|Proc.loc_exn_bucket
|] in
445 self#insert
(Iop Imove
) r1
rd;
446 self#insert_debug Iraise dbg
rd [||];
449 | Cop
(Ccmpf comp
, args
) ->
450 self#emit_expr
env (Cifthenelse
(exp
, Cconst_int
1, Cconst_int
0))
452 begin match self#emit_parts_list
env args
with
454 | Some
(simple_args
, env) ->
455 let ty = oper_result_type op
in
456 let (new_op
, new_args
) = self#select_operation op simple_args
in
457 let dbg = debuginfo_op op
in
460 Proc.contains_calls
:= true;
461 let r1 = self#emit_tuple
env new_args
in
462 let rarg = Array.sub
r1 1 (Array.length
r1 - 1) in
463 let rd = Reg.createv
ty in
464 let (loc_arg
, stack_ofs
) = Proc.loc_arguments
rarg in
465 let loc_res = Proc.loc_results
rd in
466 self#insert_move_args
rarg loc_arg stack_ofs
;
467 self#insert_debug
(Iop Icall_ind
) dbg
468 (Array.append
[|r1.(0)|] loc_arg
) loc_res;
469 self#insert_move_results
loc_res rd stack_ofs
;
472 Proc.contains_calls
:= true;
473 let r1 = self#emit_tuple
env new_args
in
474 let rd = Reg.createv
ty in
475 let (loc_arg
, stack_ofs
) = Proc.loc_arguments
r1 in
476 let loc_res = Proc.loc_results
rd in
477 self#insert_move_args
r1 loc_arg stack_ofs
;
478 self#insert_debug
(Iop
(Icall_imm lbl
)) dbg loc_arg
loc_res;
479 self#insert_move_results
loc_res rd stack_ofs
;
481 | Iextcall
(lbl
, alloc
) ->
482 Proc.contains_calls
:= true;
483 let (loc_arg
, stack_ofs
) =
484 self#emit_extcall_args
env new_args
in
485 let rd = Reg.createv
ty in
486 let loc_res = Proc.loc_external_results
rd in
487 self#insert_debug
(Iop
(Iextcall
(lbl
, alloc
))) dbg
489 self#insert_move_results
loc_res rd stack_ofs
;
492 Proc.contains_calls
:= true;
493 let rd = Reg.createv typ_addr
in
494 let size = size_expr env (Ctuple new_args
) in
495 self#insert
(Iop
(Ialloc
size)) [||] rd;
496 self#emit_stores
env new_args
rd;
499 let r1 = self#emit_tuple
env new_args
in
500 let rd = Reg.createv
ty in
501 Some
(self#insert_op_debug op
dbg r1 rd)
503 | Csequence
(e1
, e2
) ->
504 begin match self#emit_expr
env e1
with
506 | Some
r1 -> self#emit_expr
env e2
508 | Cifthenelse
(econd
, eif
, eelse
) ->
509 let (cond
, earg
) = self#select_condition econd
in
510 begin match self#emit_expr
env earg
with
513 let (rif
, sif
) = self#emit_sequence
env eif
in
514 let (relse
, selse
) = self#emit_sequence
env eelse
in
515 let r = join rif sif relse selse
in
516 self#insert
(Iifthenelse
(cond
, sif#
extract, selse#
extract))
520 | Cswitch
(esel
, index
, ecases
) ->
521 begin match self#emit_expr
env esel
with
524 let rscases = Array.map
(self#emit_sequence
env) ecases
in
525 let r = join_array rscases in
526 self#insert
(Iswitch
(index
,
527 Array.map
(fun (r, s
) -> s#
extract) rscases))
532 let (rarg, sbody
) = self#emit_sequence
env ebody
in
533 self#insert
(Iloop
(sbody#
extract)) [||] [||];
535 | Ccatch
(nfail
, ids
, e1
, e2
) ->
539 let r = Reg.createv typ_addr
in name_regs id
r; r)
541 catch_regs := (nfail
, Array.concat
rs) :: !catch_regs ;
542 let (r1, s1
) = self#emit_sequence
env e1
in
543 catch_regs := List.tl
!catch_regs ;
546 (fun env (id
,r) -> Tbl.add id
r env)
547 env (List.combine ids
rs) in
548 let (r2
, s2
) = self#emit_sequence
new_env e2
in
549 let r = join r1 s1 r2 s2
in
550 self#insert
(Icatch
(nfail
, s1#
extract, s2#
extract)) [||] [||];
552 | Cexit
(nfail
,args
) ->
553 begin match self#emit_parts_list
env args
with
555 | Some
(simple_list
, ext_env
) ->
556 let src = self#emit_tuple ext_env simple_list
in
558 try List.assoc nfail
!catch_regs
561 ("Selectgen.emit_expr, on exit("^string_of_int nfail^
")") in
562 self#insert_moves
src dest ;
563 self#insert
(Iexit nfail
) [||] [||];
566 | Ctrywith
(e1
, v
, e2
) ->
567 Proc.contains_calls
:= true;
568 let (r1, s1
) = self#emit_sequence
env e1
in
569 let rv = Reg.createv typ_addr
in
570 let (r2
, s2
) = self#emit_sequence
(Tbl.add v
rv env) e2
in
571 let r = join r1 s1 r2 s2
in
573 (Itrywith
(s1#
extract,
574 instr_cons
(Iop Imove
) [|Proc.loc_exn_bucket
|] rv
579 method private emit_sequence
env exp
=
580 let s = {< instr_seq
= dummy_instr
>} in
581 let r = s#emit_expr
env exp
in
584 method private bind_let
env v
r1 =
585 if all_regs_anonymous r1 then begin
589 let rv = Array.create
(Array.length
r1) Reg.dummy
in
590 for i
= 0 to Array.length
r1 - 1 do
591 rv.(i
) <- Reg.create
r1.(i
).typ
594 self#insert_moves
r1 rv;
598 method private emit_parts
env exp
=
599 if self#is_simple_expr exp
then
602 match self#emit_expr
env exp
with
605 match Array.length
r with
607 Some
(Ctuple
[], env)
609 (* The normal case *)
610 let id = Ident.create
"bind" in
612 if String.length
r0.name
= 0 then
613 (* r0 is an anonymous, unshared register; use it directly *)
614 Some
(Cvar
id, Tbl.add
id r env)
616 (* Introduce a fresh temp reg to hold the result *)
617 let v0 = Reg.create
r0.typ
in
618 self#insert_move
r0 v0;
619 Some
(Cvar
id, Tbl.add
id [|v0|] env)
622 (* Must not happen, we no longer support nested tuples *)
626 method private emit_parts_list
env exp_list
=
630 (* This ensures right-to-left evaluation, consistent with the
632 match self#emit_parts_list
env rem
with
634 | Some
(new_rem
, new_env) ->
635 match self#emit_parts
new_env exp
with
637 | Some
(new_exp
, fin_env
) -> Some
(new_exp
:: new_rem
, fin_env
)
639 method private emit_tuple
env exp_list
=
640 let rec emit_list = function
643 (* Again, force right-to-left evaluation *)
644 let loc_rem = emit_list rem
in
645 match self#emit_expr
env exp
with
646 None
-> assert false (* should have been caught in emit_parts *)
647 | Some loc_exp
-> loc_exp
:: loc_rem in
648 Array.concat
(emit_list exp_list
)
650 method emit_extcall_args
env args
=
651 let r1 = self#emit_tuple
env args
in
652 let (loc_arg
, stack_ofs
as arg_stack
) = Proc.loc_external_arguments
r1 in
653 self#insert_move_args
r1 loc_arg stack_ofs
;
656 method emit_stores
env data regs_addr
=
658 ref (Arch.offset_addressing
Arch.identity_addressing
(-Arch.size_int
)) in
661 let (op
, arg
) = self#select_store
!a e
in
662 match self#emit_expr
env arg
with
667 for i
= 0 to Array.length
regs - 1 do
669 let kind = if r.typ
= Float
then Double_u
else Word
in
670 self#insert
(Iop
(Istore
(kind, !a)))
671 (Array.append
[|r|] regs_addr
) [||];
672 a := Arch.offset_addressing
!a (size_component
r.typ
)
675 self#insert
(Iop op
) (Array.append
regs regs_addr
) [||];
676 a := Arch.offset_addressing
!a (size_expr env e
))
679 (* Same, but in tail position *)
681 method private emit_return
env exp
=
682 match self#emit_expr
env exp
with
685 let loc = Proc.loc_results
r in
686 self#insert_moves
r loc;
687 self#insert Ireturn
loc [||]
689 method emit_tail
env exp
=
692 begin match self#emit_expr
env e1
with
694 | Some
r1 -> self#emit_tail
(self#bind_let
env v
r1) e2
696 | Cop
(Capply
(ty, dbg) as op
, args
) ->
697 begin match self#emit_parts_list
env args
with
699 | Some
(simple_args
, env) ->
700 let (new_op
, new_args
) = self#select_operation op simple_args
in
703 let r1 = self#emit_tuple
env new_args
in
704 let rarg = Array.sub
r1 1 (Array.length
r1 - 1) in
705 let (loc_arg
, stack_ofs
) = Proc.loc_arguments
rarg in
706 if stack_ofs
= 0 then begin
707 self#insert_moves
rarg loc_arg
;
708 self#insert
(Iop Itailcall_ind
)
709 (Array.append
[|r1.(0)|] loc_arg
) [||]
711 Proc.contains_calls
:= true;
712 let rd = Reg.createv
ty in
713 let loc_res = Proc.loc_results
rd in
714 self#insert_move_args
rarg loc_arg stack_ofs
;
715 self#insert_debug
(Iop Icall_ind
) dbg
716 (Array.append
[|r1.(0)|] loc_arg
) loc_res;
717 self#insert
(Iop
(Istackoffset
(-stack_ofs
))) [||] [||];
718 self#insert Ireturn
loc_res [||]
721 let r1 = self#emit_tuple
env new_args
in
722 let (loc_arg
, stack_ofs
) = Proc.loc_arguments
r1 in
723 if stack_ofs
= 0 then begin
724 self#insert_moves
r1 loc_arg
;
725 self#insert
(Iop
(Itailcall_imm lbl
)) loc_arg
[||]
726 end else if lbl
= !current_function_name then begin
727 let loc_arg'
= Proc.loc_parameters
r1 in
728 self#insert_moves
r1 loc_arg'
;
729 self#insert
(Iop
(Itailcall_imm lbl
)) loc_arg'
[||]
731 Proc.contains_calls
:= true;
732 let rd = Reg.createv
ty in
733 let loc_res = Proc.loc_results
rd in
734 self#insert_move_args
r1 loc_arg stack_ofs
;
735 self#insert_debug
(Iop
(Icall_imm lbl
)) dbg loc_arg loc_res;
736 self#insert
(Iop
(Istackoffset
(-stack_ofs
))) [||] [||];
737 self#insert Ireturn
loc_res [||]
739 | _
-> fatal_error
"Selection.emit_tail"
741 | Csequence
(e1
, e2
) ->
742 begin match self#emit_expr
env e1
with
744 | Some
r1 -> self#emit_tail
env e2
746 | Cifthenelse
(econd
, eif
, eelse
) ->
747 let (cond
, earg
) = self#select_condition econd
in
748 begin match self#emit_expr
env earg
with
751 self#insert
(Iifthenelse
(cond
, self#emit_tail_sequence
env eif
,
752 self#emit_tail_sequence
env eelse
))
755 | Cswitch
(esel
, index
, ecases
) ->
756 begin match self#emit_expr
env esel
with
760 (Iswitch
(index
, Array.map
(self#emit_tail_sequence
env) ecases
))
763 | Ccatch
(nfail
, ids
, e1
, e2
) ->
767 let r = Reg.createv typ_addr
in
771 catch_regs := (nfail
, Array.concat
rs) :: !catch_regs ;
772 let s1 = self#emit_tail_sequence
env e1
in
773 catch_regs := List.tl
!catch_regs ;
776 (fun env (id,r) -> Tbl.add
id r env)
777 env (List.combine ids
rs) in
778 let s2 = self#emit_tail_sequence
new_env e2
in
779 self#insert
(Icatch
(nfail
, s1, s2)) [||] [||]
780 | Ctrywith
(e1
, v
, e2
) ->
781 Proc.contains_calls
:= true;
782 let (opt_r1
, s1) = self#emit_sequence
env e1
in
783 let rv = Reg.createv typ_addr
in
784 let s2 = self#emit_tail_sequence
(Tbl.add v
rv env) e2
in
786 (Itrywith
(s1#
extract,
787 instr_cons
(Iop Imove
) [|Proc.loc_exn_bucket
|] rv s2))
789 begin match opt_r1
with
792 let loc = Proc.loc_results
r1 in
793 self#insert_moves
r1 loc;
794 self#insert Ireturn
loc [||]
797 self#emit_return
env exp
799 method private emit_tail_sequence
env exp
=
800 let s = {< instr_seq
= dummy_instr
>} in
804 (* Sequentialization of a function definition *)
806 method emit_fundecl f
=
807 Proc.contains_calls
:= false;
808 current_function_name := f
.Cmm.fun_name
;
811 (fun (id, ty) -> let r = Reg.createv
ty in name_regs id r; r)
813 let rarg = Array.concat
rargs in
814 let loc_arg = Proc.loc_parameters
rarg in
817 (fun (id, ty) r env -> Tbl.add
id r env)
818 f
.Cmm.fun_args
rargs Tbl.empty
in
819 self#insert_moves
loc_arg rarg;
820 self#emit_tail
env f
.Cmm.fun_body
;
821 { fun_name
= f
.Cmm.fun_name
;
823 fun_body
= self#
extract;
824 fun_fast
= f
.Cmm.fun_fast
}