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 (* Transformation of Mach code into a list of pseudo-instructions. *)
22 let label_counter = ref 99
24 let new_label() = incr
label_counter; !label_counter
27 { mutable desc
: instruction_desc
;
28 mutable next
: instruction
;
34 and instruction_desc
=
41 | Lcondbranch
of test
* label
42 | Lcondbranch3
of label
option * label
option * label
option
43 | Lswitch
of label array
49 let has_fallthrough = function
50 | Lreturn
| Lbranch _
| Lswitch _
| Lraise
51 | Lop Itailcall_ind
| Lop
(Itailcall_imm _
) -> false
56 fun_body
: instruction
;
61 let invert_integer_test = function
62 Isigned cmp
-> Isigned
(Cmm.negate_comparison cmp
)
63 | Iunsigned cmp
-> Iunsigned
(Cmm.negate_comparison cmp
)
65 let invert_test = function
66 Itruetest
-> Ifalsetest
67 | Ifalsetest
-> Itruetest
68 | Iinttest
(cmp
) -> Iinttest
(invert_integer_test cmp
)
69 | Iinttest_imm
(cmp
, n
) -> Iinttest_imm
(invert_integer_test cmp
, n
)
70 | Ifloattest
(cmp
, neg
) -> Ifloattest
(cmp
, not neg
)
71 | Ieventest
-> Ioddtest
72 | Ioddtest
-> Ieventest
74 (* The "end" instruction *)
82 live
= Reg.Set.empty
}
84 (* Cons an instruction (live, debug empty) *)
86 let instr_cons d a r n
=
87 { desc
= d
; next
= n
; arg
= a
; res
= r
;
88 dbg
= Debuginfo.none
; live
= Reg.Set.empty
}
90 (* Cons a simple instruction (arg, res, live empty) *)
93 { desc
= d
; next
= n
; arg
= [||]; res
= [||];
94 dbg
= Debuginfo.none
; live
= Reg.Set.empty
}
96 (* Build an instruction with arg, res, dbg, live taken from
97 the given Mach.instruction *)
99 let copy_instr d i n
=
100 { desc
= d
; next
= n
;
101 arg
= i
.Mach.arg
; res
= i
.Mach.res
;
102 dbg
= i
.Mach.dbg
; live
= i
.Mach.live
}
105 Label the beginning of the given instruction sequence.
106 - If the sequence starts with a branch, jump over it.
107 - If the sequence is the end, (tail call position), just do nothing
110 let get_label n
= match n
.desc
with
111 Lbranch lbl
-> (lbl
, n
)
112 | Llabel lbl
-> (lbl
, n
)
114 | _
-> let lbl = new_label() in (lbl, cons_instr (Llabel
lbl) n
)
116 (* Check the fallthrough label *)
117 let check_label n
= match n
.desc
with
122 (* Discard all instructions up to the next label.
123 This function is to be called before adding a non-terminating
126 let rec discard_dead_code n
=
130 (* Do not discard Lpoptrap or Istackoffset instructions,
131 as this may cause a stack imbalance later during assembler generation. *)
133 | Lop
(Istackoffset _
) -> n
134 | _
-> discard_dead_code n
.next
137 Add a branch in front of a continuation.
138 Discard dead code in the continuation.
139 Does not insert anything if we're just falling through
140 or if we jump to dead code after the end of function (lbl=-1)
143 let add_branch lbl n
=
145 let n1 = discard_dead_code n
in
147 | Llabel lbl1
when lbl1
= lbl -> n1
148 | _
-> cons_instr (Lbranch
lbl) n1
152 (* Current labels for exit handler *)
154 let exit_label = ref []
156 let find_exit_label k
=
158 List.assoc k
!exit_label
160 | Not_found
-> Misc.fatal_error
"Linearize.find_exit_label"
162 let is_next_catch n
= match !exit_label with
163 | (n0
,_
)::_
when n0
=n
-> true
166 (* Linearize an instruction [i]: add it in front of the continuation [n] *)
169 match i
.Mach.desc
with
171 | Iop
(Itailcall_ind
| Itailcall_imm _
as op
) ->
172 copy_instr (Lop op
) i
(discard_dead_code n
)
173 | Iop
(Imove
| Ireload
| Ispill
)
174 when i
.Mach.arg
.(0).loc
= i
.Mach.res
.(0).loc
->
177 copy_instr (Lop op
) i
(linear i
.Mach.next n
)
179 let n1 = copy_instr Lreturn i
(discard_dead_code n
) in
180 if !Proc.contains_calls
181 then cons_instr Lreloadretaddr
n1
183 | Iifthenelse
(test
, ifso
, ifnot
) ->
184 let n1 = linear i
.Mach.next n
in
185 begin match (ifso
.Mach.desc
, ifnot
.Mach.desc
, n1.desc
) with
186 Iend
, _
, Lbranch
lbl ->
187 copy_instr (Lcondbranch
(test
, lbl)) i
(linear ifnot
n1)
188 | _
, Iend
, Lbranch
lbl ->
189 copy_instr (Lcondbranch
(invert_test test
, lbl)) i
(linear ifso
n1)
190 | Iexit nfail1
, Iexit nfail2
, _
191 when is_next_catch nfail1
->
192 let lbl2 = find_exit_label nfail2
in
194 (Lcondbranch
(invert_test test
, lbl2)) i
(linear ifso
n1)
195 | Iexit nfail
, _
, _
->
196 let n2 = linear ifnot
n1
197 and lbl = find_exit_label nfail
in
198 copy_instr (Lcondbranch
(test
, lbl)) i
n2
199 | _
, Iexit nfail
, _
->
200 let n2 = linear ifso
n1 in
201 let lbl = find_exit_label nfail
in
202 copy_instr (Lcondbranch
(invert_test test
, lbl)) i
n2
204 let (lbl_end
, n2) = get_label n1 in
205 copy_instr (Lcondbranch
(test
, lbl_end
)) i
(linear ifnot
n2)
207 let (lbl_end
, n2) = get_label n1 in
208 copy_instr (Lcondbranch
(invert_test test
, lbl_end
)) i
211 (* Should attempt branch prediction here *)
212 let (lbl_end
, n2) = get_label n1 in
213 let (lbl_else
, nelse
) = get_label (linear ifnot
n2) in
214 copy_instr (Lcondbranch
(invert_test test
, lbl_else
)) i
215 (linear ifso
(add_branch lbl_end nelse
))
217 | Iswitch
(index
, cases
) ->
218 let lbl_cases = Array.create
(Array.length cases
) 0 in
219 let (lbl_end
, n1) = get_label(linear i
.Mach.next n
) in
220 let n2 = ref (discard_dead_code n1) in
221 for i
= Array.length cases
- 1 downto 0 do
222 let (lbl_case
, ncase
) =
223 get_label(linear cases
.(i
) (add_branch lbl_end
!n2)) in
224 lbl_cases.(i
) <- lbl_case
;
225 n2 := discard_dead_code ncase
227 (* Switches with 1 and 2 branches have been eliminated earlier.
228 Here, we do something for switches with 3 branches. *)
229 if Array.length index
= 3 then begin
230 let fallthrough_lbl = check_label !n2 in
232 let lbl = lbl_cases.(index
.(n
)) in
233 if lbl = fallthrough_lbl then None
else Some
lbl in
234 copy_instr (Lcondbranch3
(find_label 0, find_label 1, find_label 2))
237 copy_instr (Lswitch
(Array.map
(fun n
-> lbl_cases.(n
)) index
)) i
!n2
239 let lbl_head = new_label() in
240 let n1 = linear i
.Mach.next n
in
241 let n2 = linear body
(cons_instr (Lbranch
lbl_head) n1) in
242 cons_instr (Llabel
lbl_head) n2
243 | Icatch
(io
, body
, handler
) ->
244 let (lbl_end
, n1) = get_label(linear i
.Mach.next n
) in
245 let (lbl_handler
, n2) = get_label(linear handler
n1) in
246 exit_label := (io
, lbl_handler
) :: !exit_label ;
247 let n3 = linear body
(add_branch lbl_end
n2) in
248 exit_label := List.tl
!exit_label;
251 let n1 = linear i
.Mach.next n
in
252 let lbl = find_exit_label nfail
in
254 | Itrywith
(body
, handler
) ->
255 let (lbl_join
, n1) = get_label (linear i
.Mach.next n
) in
257 get_label (cons_instr Lpushtrap
258 (linear body
(cons_instr Lpoptrap
n1))) in
259 cons_instr (Lsetuptrap lbl_body
)
260 (linear handler
(add_branch lbl_join
n2))
262 copy_instr Lraise i
(discard_dead_code n
)
265 { fun_name
= f
.Mach.fun_name
;
266 fun_body
= linear f
.Mach.fun_body
end_instr;
267 fun_fast
= f
.Mach.fun_fast
}