asmcomp/spill.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   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.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Insertion of moves to suggest possible spilling / reloading points
  16    before register allocation. *)
  17
  18 open Reg
  19 open Mach
  20
  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.
  24
  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.
  29
  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. *)
  34
  35 (* Association of spill registers to registers *)
  36
  37 let spill_env = ref (Reg.Map.empty : Reg.t Reg.Map.t)
  38
  39 let spill_reg r =
  40   try
  41     Reg.Map.find r !spill_env
  42   with Not_found ->
  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;
  47     spill_r
  48
  49 (* Record the position of last use of registers *)
  50
  51 let use_date = ref (Reg.Map.empty : int Reg.Map.t)
  52 let current_date = ref 0
  53
  54 let record_use regv =
  55   for i = 0 to Array.length regv - 1 do
  56     let r = regv.(i) in
  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
  60   done
  61
  62 (* Check if the register pressure overflows the maximum pressure allowed
  63    at that point. If so, spill enough registers to lower the pressure. *)
  64
  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
  70   Reg.Set.iter
  71     (fun r ->
  72       if Reg.Set.mem r spilled then () else begin
  73         match r.loc with
  74           Stack s -> ()
  75         | _ -> let c = Proc.register_class r in
  76                pressure.(c) <- pressure.(c) + 1
  77       end)
  78     regs;
  79   (* Check if pressure is exceeded for each class. *)
  80   let rec check_pressure cl spilled =
  81     if cl >= Proc.num_register_classes then
  82       spilled
  83     else if pressure.(cl) <= max_pressure.(cl) then
  84       check_pressure (cl+1) spilled
  85     else begin
  86       (* Find the least recently used, unspilled, unallocated, live register
  87          in the class *)
  88       let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in
  89       Reg.Set.iter
  90         (fun r ->
  91           if Proc.register_class r = cl &&
  92              not (Reg.Set.mem r spilled) &&
  93              r.loc = Unknown
  94           then begin
  95             try
  96               let d = Reg.Map.find r !use_date in
  97               if d < !lru_date then begin
  98                 lru_date := d;
  99                 lru_reg := r
 100               end
 101             with Not_found ->                 (* Should not happen *)
 102               ()
 103           end)
 104         live_regs;
 105       if !lru_reg != Reg.dummy then begin
 106         pressure.(cl) <- pressure.(cl) - 1;
 107         check_pressure cl (Reg.Set.add !lru_reg spilled)
 108       end else
 109         (* Couldn't find any spillable register, give up for this class *)
 110         check_pressure (cl+1) spilled
 111     end in
 112   check_pressure 0 spilled
 113
 114 (* A-list recording what is destroyed at if-then-else points. *)
 115
 116 let destroyed_at_fork = ref ([] : (instruction * Reg.Set.t) list)
 117
 118 (* First pass: insert reload instructions based on an approximation of
 119    what is destroyed at pressure points. *)
 120
 121 let add_reloads regset i =
 122   Reg.Set.fold
 123     (fun r i -> instr_cons (Iop Ireload) [|spill_reg r|] [|r|] i)
 124     regset i
 125
 126 let reload_at_exit = ref []
 127
 128 let find_reload_at_exit k =
 129   try
 130     List.assoc k !reload_at_exit
 131   with
 132   | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit"
 133
 134 let reload_at_break = ref Reg.Set.empty
 135
 136 let rec reload i before =
 137   incr current_date;
 138   record_use i.arg;
 139   record_use i.res;
 140   match i.desc with
 141     Iend ->
 142       (i, before)
 143   | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
 144       (add_reloads (Reg.inter_set_array before i.arg) i,
 145        Reg.Set.empty)
 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),
 151        finally)
 152   | Iop op ->
 153       let new_before =
 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
 157         then before
 158         else add_superpressure_regs op i.live i.res before in
 159       let after =
 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),
 164        finally)
 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
 175       let new_i =
 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,
 180        finally)
 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
 186       let new_cases =
 187         Array.map
 188           (fun c ->
 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;
 193             new_c)
 194           cases in
 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),
 200        finally)
 201   | Iloop(body) ->
 202       let date_start = !current_date in
 203       let at_head = ref before in
 204       let final_body = ref body in
 205       begin try
 206         while true do
 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;
 212             raise Exit
 213           end;
 214           at_head := merged_at_head
 215         done
 216       with Exit -> ()
 217       end;
 218       let (new_next, finally) = reload i.next Reg.Set.empty in
 219       (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
 220        finally)
 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,
 231        finally)
 232   | Iexit nfail ->
 233       let set = find_reload_at_exit nfail in
 234       set := Reg.Set.union !set before;
 235       (i, Reg.Set.empty)
 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,
 242        finally)
 243   | Iraise ->
 244       (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty)
 245
 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. *)
 249
 250 (*
 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 ?
 259 *)
 260
 261
 262 let spill_at_exit = ref []
 263 let find_spill_at_exit k =
 264   try
 265     List.assoc k !spill_at_exit
 266   with
 267   | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit"
 268
 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
 273
 274 let add_spills regset i =
 275   Reg.Set.fold
 276     (fun r i -> instr_cons (Iop Ispill) [|r|] [|spill_reg r|] i)
 277     regset i
 278
 279 let rec spill i finally =
 280   match i.desc with
 281     Iend ->
 282       (i, finally)
 283   | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
 284       (i, Reg.Set.empty)
 285   | Iop Ireload ->
 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)
 290   | Iop _ ->
 291       let (new_next, after) = spill i.next finally in
 292       let before1 = Reg.diff_set_array after i.res in
 293       let before =
 294         match i.desc with
 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
 298         | _ ->
 299             before1 in
 300       (instr_cons_debug i.desc i.arg i.res i.dbg
 301                   (add_spills (Reg.inter_set_array after i.res) new_next),
 302        before)
 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
 307       if
 308         !inside_loop || !inside_arm
 309       then
 310         (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
 311                      i.arg i.res new_next,
 312          Reg.Set.union before_ifso before_ifnot)
 313       else begin
 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
 319         (instr_cons
 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)
 324                                     spill_ifso_branch)
 325                        spill_ifnot_branch)
 326       end
 327   | Iswitch(index, cases) ->
 328       let (new_next, at_join) = spill i.next finally in
 329       let saved_inside_arm = !inside_arm in
 330       inside_arm := true ;
 331       let before = ref Reg.Set.empty in
 332       let new_cases =
 333         Array.map
 334           (fun c ->
 335             let (new_c, before_c) = spill c at_join in
 336             before := Reg.Set.union !before before_c;
 337             new_c)
 338           cases in
 339       inside_arm := saved_inside_arm ;
 340       (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next,
 341        !before)
 342   | Iloop(body) ->
 343       let (new_next, _) = spill i.next finally in
 344       let saved_inside_loop = !inside_loop in
 345       inside_loop := true;
 346       let at_head = ref Reg.Set.empty in
 347       let final_body = ref body in
 348       begin try
 349         while true do
 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
 354           end;
 355           at_head := new_at_head
 356         done
 357       with Exit -> ()
 358       end;
 359       inside_loop := saved_inside_loop;
 360       (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
 361        !at_head)
 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,
 372        before)
 373   | Iexit nfail ->
 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,
 383        before_body)
 384   | Iraise ->
 385       (i, !spill_at_raise)
 386
 387 (* Entry point *)
 388
 389 let fundecl f =
 390   spill_env := Reg.Map.empty;
 391   use_date := Reg.Map.empty;
 392   current_date := 0;
 393   let (body1, _) = reload f.fun_body Reg.Set.empty in
 394   let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in
 395   let new_body =
 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;
 401     fun_body = new_body;
 402     fun_fast = f.fun_fast }
 403