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 (* Insertion of moves to suggest possible spilling / reloading points
16 before register allocation. *)
21 (* We say that a register is "destroyed" if it is live across a construct
22 that potentially destroys all physical registers: function calls or
23 try...with constructs.
25 The "destroyed" registers must therefore reside in the stack during
26 these instructions.. We will insert spills (stores) just after they
27 are defined, and reloads just before their first use following a
28 "destroying" construct.
30 Instructions with more live registers than actual registers also
31 "destroy" registers: we mark as "destroyed" the registers live
32 across the instruction that haven't been used for the longest time.
33 These registers will be spilled and reloaded as described above. *)
35 (* Association of spill registers to registers *)
37 let spill_env = ref (Reg.Map.empty
: Reg.t
Reg.Map.t
)
41 Reg.Map.find r
!spill_env
43 let spill_r = Reg.create r
.typ
in
44 spill_r.spill
<- true;
45 if String.length r
.name
> 0 then spill_r.name
<- "spilled-" ^ r
.name
;
46 spill_env := Reg.Map.add r
spill_r !spill_env;
49 (* Record the position of last use of registers *)
51 let use_date = ref (Reg.Map.empty
: int Reg.Map.t
)
52 let current_date = ref 0
55 for i
= 0 to Array.length regv
- 1 do
57 let prev_date = try Reg.Map.find
r !use_date with Not_found
-> 0 in
58 if !current_date > prev_date then
59 use_date := Reg.Map.add
r !current_date !use_date
62 (* Check if the register pressure overflows the maximum pressure allowed
63 at that point. If so, spill enough registers to lower the pressure. *)
65 let add_superpressure_regs op live_regs res_regs spilled
=
66 let max_pressure = Proc.max_register_pressure op
in
67 let regs = Reg.add_set_array live_regs res_regs
in
68 (* Compute the pressure in each register class *)
69 let pressure = Array.create
Proc.num_register_classes
0 in
72 if Reg.Set.mem
r spilled
then () else begin
75 | _
-> let c = Proc.register_class
r in
76 pressure.(c) <- pressure.(c) + 1
79 (* Check if pressure is exceeded for each class. *)
80 let rec check_pressure cl spilled
=
81 if cl
>= Proc.num_register_classes
then
83 else if pressure.(cl
) <= max_pressure.(cl
) then
84 check_pressure (cl
+1) spilled
86 (* Find the least recently used, unspilled, unallocated, live register
88 let lru_date = ref 1000000 and lru_reg
= ref Reg.dummy
in
91 if Proc.register_class
r = cl
&&
92 not
(Reg.Set.mem
r spilled
) &&
96 let d = Reg.Map.find
r !use_date in
97 if d < !lru_date then begin
101 with Not_found
-> (* Should not happen *)
105 if !lru_reg
!= Reg.dummy
then begin
106 pressure.(cl
) <- pressure.(cl
) - 1;
107 check_pressure cl
(Reg.Set.add
!lru_reg spilled
)
109 (* Couldn't find any spillable register, give up for this class *)
110 check_pressure (cl
+1) spilled
112 check_pressure 0 spilled
114 (* A-list recording what is destroyed at if-then-else points. *)
116 let destroyed_at_fork = ref ([] : (instruction
* Reg.Set.t
) list
)
118 (* First pass: insert reload instructions based on an approximation of
119 what is destroyed at pressure points. *)
121 let add_reloads regset i
=
123 (fun r i
-> instr_cons
(Iop Ireload
) [|spill_reg r|] [|r|] i
)
126 let reload_at_exit = ref []
128 let find_reload_at_exit k
=
130 List.assoc k
!reload_at_exit
132 | Not_found
-> Misc.fatal_error
"Spill.find_reload_at_exit"
134 let reload_at_break = ref Reg.Set.empty
136 let rec reload i before
=
143 | Ireturn
| Iop
(Itailcall_ind
) | Iop
(Itailcall_imm _
) ->
144 (add_reloads (Reg.inter_set_array before i
.arg
) i
,
146 | Iop
(Icall_ind
| Icall_imm _
| Iextcall
(_
, true)) ->
147 (* All regs live across must be spilled *)
148 let (new_next
, finally
) = reload i
.next i
.live
in
149 (add_reloads (Reg.inter_set_array before i
.arg
)
150 (instr_cons_debug i
.desc i
.arg i
.res i
.dbg new_next
),
154 (* Quick check to see if the register pressure is below the maximum *)
155 if Reg.Set.cardinal i
.live
+ Array.length i
.res
<=
156 Proc.safe_register_pressure op
158 else add_superpressure_regs op i
.live i
.res before
in
160 Reg.diff_set_array
(Reg.diff_set_array
new_before i
.arg
) i
.res
in
161 let (new_next
, finally
) = reload i
.next
after in
162 (add_reloads (Reg.inter_set_array
new_before i
.arg
)
163 (instr_cons_debug i
.desc i
.arg i
.res i
.dbg new_next
),
165 | Iifthenelse
(test
, ifso
, ifnot
) ->
166 let at_fork = Reg.diff_set_array before i
.arg
in
167 let date_fork = !current_date in
168 let (new_ifso
, after_ifso
) = reload ifso
at_fork in
169 let date_ifso = !current_date in
170 current_date := date_fork;
171 let (new_ifnot
, after_ifnot
) = reload ifnot
at_fork in
172 current_date := max
date_ifso !current_date;
173 let (new_next
, finally
) =
174 reload i
.next
(Reg.Set.union after_ifso after_ifnot
) in
176 instr_cons
(Iifthenelse
(test
, new_ifso
, new_ifnot
))
177 i
.arg i
.res new_next
in
178 destroyed_at_fork := (new_i, at_fork) :: !destroyed_at_fork;
179 (add_reloads (Reg.inter_set_array before i
.arg
) new_i,
181 | Iswitch
(index
, cases
) ->
182 let at_fork = Reg.diff_set_array before i
.arg
in
183 let date_fork = !current_date in
184 let date_join = ref 0 in
185 let after_cases = ref Reg.Set.empty
in
189 current_date := date_fork;
190 let (new_c
, after_c
) = reload c at_fork in
191 after_cases := Reg.Set.union
!after_cases after_c
;
192 date_join := max
!date_join !current_date;
195 current_date := !date_join;
196 let (new_next
, finally
) = reload i
.next
!after_cases in
197 (add_reloads (Reg.inter_set_array before i
.arg
)
198 (instr_cons
(Iswitch
(index
, new_cases))
199 i
.arg i
.res new_next
),
202 let date_start = !current_date in
203 let at_head = ref before
in
204 let final_body = ref body
in
207 current_date := date_start;
208 let (new_body
, new_at_head
) = reload body
!at_head in
209 let merged_at_head = Reg.Set.union
!at_head new_at_head
in
210 if Reg.Set.equal
merged_at_head !at_head then begin
211 final_body := new_body
;
214 at_head := merged_at_head
218 let (new_next
, finally
) = reload i
.next
Reg.Set.empty
in
219 (instr_cons
(Iloop
(!final_body)) i
.arg i
.res new_next
,
221 | Icatch
(nfail
, body
, handler
) ->
222 let new_set = ref Reg.Set.empty
in
223 reload_at_exit := (nfail
, new_set) :: !reload_at_exit ;
224 let (new_body
, after_body
) = reload body before
in
225 let at_exit = !new_set in
226 reload_at_exit := List.tl
!reload_at_exit ;
227 let (new_handler
, after_handler
) = reload handler
at_exit in
228 let (new_next
, finally
) =
229 reload i
.next
(Reg.Set.union after_body after_handler
) in
230 (instr_cons
(Icatch
(nfail
, new_body
, new_handler
)) i
.arg i
.res new_next
,
233 let set = find_reload_at_exit nfail
in
234 set := Reg.Set.union
!set before
;
236 | Itrywith
(body
, handler
) ->
237 let (new_body
, after_body
) = reload body before
in
238 let (new_handler
, after_handler
) = reload handler handler
.live
in
239 let (new_next
, finally
) =
240 reload i
.next
(Reg.Set.union after_body after_handler
) in
241 (instr_cons
(Itrywith
(new_body
, new_handler
)) i
.arg i
.res new_next
,
244 (add_reloads (Reg.inter_set_array before i
.arg
) i
, Reg.Set.empty
)
246 (* Second pass: add spill instructions based on what we've decided to reload.
247 That is, any register that may be reloaded in the future must be spilled
248 just after its definition. *)
251 As an optimization, if a register needs to be spilled in one branch of
252 a conditional but not in the other, then we spill it late on entrance
253 in the branch that needs it spilled.
254 NB: This strategy is turned off in loops, as it may prevent a spill from
255 being lifted up all the way out of the loop.
256 NB again: This strategy is also off in switch arms
257 as it generates many useless spills inside switch arms
258 NB ter: is it the same thing for catch bodies ?
262 let spill_at_exit = ref []
263 let find_spill_at_exit k
=
265 List.assoc k
!spill_at_exit
267 | Not_found
-> Misc.fatal_error
"Spill.find_spill_at_exit"
269 let spill_at_raise = ref Reg.Set.empty
270 let inside_loop = ref false
271 and inside_arm
= ref false
272 and inside_catch
= ref false
274 let add_spills regset i
=
276 (fun r i
-> instr_cons
(Iop Ispill
) [|r|] [|spill_reg r|] i
)
279 let rec spill i finally
=
283 | Ireturn
| Iop
(Itailcall_ind
) | Iop
(Itailcall_imm _
) ->
286 let (new_next
, after) = spill i
.next finally
in
287 let before1 = Reg.diff_set_array
after i
.res
in
288 (instr_cons i
.desc i
.arg i
.res new_next
,
289 Reg.add_set_array
before1 i
.res
)
291 let (new_next
, after) = spill i
.next finally
in
292 let before1 = Reg.diff_set_array
after i
.res
in
295 Iop Icall_ind
| Iop
(Icall_imm _
) | Iop
(Iextcall _
)
296 | Iop
(Iintop Icheckbound
) | Iop
(Iintop_imm
(Icheckbound
, _
)) ->
297 Reg.Set.union
before1 !spill_at_raise
300 (instr_cons_debug i
.desc i
.arg i
.res i
.dbg
301 (add_spills (Reg.inter_set_array
after i
.res
) new_next
),
303 | Iifthenelse
(test
, ifso
, ifnot
) ->
304 let (new_next
, at_join
) = spill i
.next finally
in
305 let (new_ifso
, before_ifso
) = spill ifso at_join
in
306 let (new_ifnot
, before_ifnot
) = spill ifnot at_join
in
308 !inside_loop || !inside_arm
310 (instr_cons
(Iifthenelse
(test
, new_ifso
, new_ifnot
))
311 i
.arg i
.res new_next
,
312 Reg.Set.union before_ifso before_ifnot
)
314 let destroyed = List.assq i
!destroyed_at_fork in
315 let spill_ifso_branch =
316 Reg.Set.diff
(Reg.Set.diff before_ifso before_ifnot
) destroyed
317 and spill_ifnot_branch
=
318 Reg.Set.diff
(Reg.Set.diff before_ifnot before_ifso
) destroyed in
320 (Iifthenelse
(test
, add_spills spill_ifso_branch new_ifso
,
321 add_spills spill_ifnot_branch new_ifnot
))
322 i
.arg i
.res new_next
,
323 Reg.Set.diff
(Reg.Set.diff
(Reg.Set.union before_ifso before_ifnot
)
327 | Iswitch
(index
, cases
) ->
328 let (new_next
, at_join
) = spill i
.next finally
in
329 let saved_inside_arm = !inside_arm
in
331 let before = ref Reg.Set.empty
in
335 let (new_c
, before_c
) = spill c at_join
in
336 before := Reg.Set.union
!before before_c
;
339 inside_arm
:= saved_inside_arm ;
340 (instr_cons
(Iswitch
(index
, new_cases)) i
.arg i
.res new_next
,
343 let (new_next
, _
) = spill i
.next finally
in
344 let saved_inside_loop = !inside_loop in
346 let at_head = ref Reg.Set.empty
in
347 let final_body = ref body
in
350 let (new_body
, before_body
) = spill body
!at_head in
351 let new_at_head = Reg.Set.union
!at_head before_body
in
352 if Reg.Set.equal
new_at_head !at_head then begin
353 final_body := new_body
; raise Exit
355 at_head := new_at_head
359 inside_loop := saved_inside_loop;
360 (instr_cons
(Iloop
(!final_body)) i
.arg i
.res new_next
,
362 | Icatch
(nfail
, body
, handler
) ->
363 let (new_next
, at_join
) = spill i
.next finally
in
364 let (new_handler
, at_exit) = spill handler at_join
in
365 let saved_inside_catch = !inside_catch
in
366 inside_catch
:= true ;
367 spill_at_exit := (nfail
, at_exit) :: !spill_at_exit ;
368 let (new_body
, before) = spill body at_join
in
369 spill_at_exit := List.tl
!spill_at_exit;
370 inside_catch
:= saved_inside_catch ;
371 (instr_cons
(Icatch
(nfail
, new_body
, new_handler
)) i
.arg i
.res new_next
,
374 (i
, find_spill_at_exit nfail
)
375 | Itrywith
(body
, handler
) ->
376 let (new_next
, at_join
) = spill i
.next finally
in
377 let (new_handler
, before_handler
) = spill handler at_join
in
378 let saved_spill_at_raise = !spill_at_raise in
379 spill_at_raise := before_handler
;
380 let (new_body
, before_body
) = spill body at_join
in
381 spill_at_raise := saved_spill_at_raise;
382 (instr_cons
(Itrywith
(new_body
, new_handler
)) i
.arg i
.res new_next
,
390 spill_env := Reg.Map.empty
;
391 use_date := Reg.Map.empty
;
393 let (body1
, _
) = reload f
.fun_body
Reg.Set.empty
in
394 let (body2
, tospill_at_entry
) = spill body1
Reg.Set.empty
in
396 add_spills (Reg.inter_set_array tospill_at_entry f
.fun_args
) body2
in
397 spill_env := Reg.Map.empty
;
398 use_date := Reg.Map.empty
;
399 { fun_name
= f
.fun_name
;
400 fun_args
= f
.fun_args
;
402 fun_fast
= f
.fun_fast
}