l4/pkg/ocaml/contrib/asmcomp/split.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: split.ml 7812 2007-01-29 12:11:18Z xleroy $ *)
  14
  15 (* Renaming of registers at reload points to split live ranges. *)
  16
  17 open Reg
  18 open Mach
  19
  20 (* Substitutions are represented by register maps *)
  21
  22 type subst = Reg.t Reg.Map.t
  23
  24 let subst_reg r sub =
  25   try
  26     Reg.Map.find r sub
  27   with Not_found ->
  28     r
  29
  30 let subst_regs rv sub =
  31   match sub with
  32     None -> rv
  33   | Some s ->
  34       let n = Array.length rv in
  35       let nv = Array.create n Reg.dummy in
  36       for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done;
  37       nv
  38
  39 (* We maintain equivalence classes of registers using a standard
  40    union-find algorithm *)
  41
  42 let equiv_classes = ref (Reg.Map.empty : Reg.t Reg.Map.t)
  43
  44 let rec repres_reg r =
  45   try
  46     repres_reg(Reg.Map.find r !equiv_classes)
  47   with Not_found ->
  48     r
  49
  50 let repres_regs rv =
  51   let n = Array.length rv in
  52   for i = 0 to n-1 do rv.(i) <- repres_reg rv.(i) done
  53
  54 (* Identify two registers.
  55    The second register is chosen as canonical representative. *)
  56
  57 let identify r1 r2 =
  58   let repres1 = repres_reg r1 in
  59   let repres2 = repres_reg r2 in
  60   if repres1.stamp = repres2.stamp then () else begin
  61     equiv_classes := Reg.Map.add repres1 repres2 !equiv_classes
  62   end
  63
  64 (* Identify the image of a register by two substitutions.
  65    Be careful to use the original register as canonical representative
  66    in case it does not belong to the domain of one of the substitutions. *)
  67
  68 let identify_sub sub1 sub2 reg =
  69   try
  70     let r1 = Reg.Map.find reg sub1 in
  71     try
  72       let r2 = Reg.Map.find reg sub2 in
  73       identify r1 r2
  74     with Not_found ->
  75       identify r1 reg
  76   with Not_found ->
  77     try
  78       let r2 = Reg.Map.find reg sub2 in
  79       identify r2 reg
  80     with Not_found ->
  81       ()
  82
  83 (* Identify registers so that the two substitutions agree on the
  84    registers live before the given instruction. *)
  85
  86 let merge_substs sub1 sub2 i =
  87   match (sub1, sub2) with
  88     (None, None) -> None
  89   | (Some s1, None) -> sub1
  90   | (None, Some s2) -> sub2
  91   | (Some s1, Some s2) ->
  92       Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg);
  93       sub1
  94
  95 (* Same, for N substitutions *)
  96
  97 let merge_subst_array subv instr =
  98   let rec find_one_subst i =
  99     if i >= Array.length subv then None else begin
 100       match subv.(i) with
 101         None -> find_one_subst (i+1)
 102       | Some si as sub ->
 103           for j = i+1 to Array.length subv - 1 do
 104             match subv.(j) with
 105               None -> ()
 106             | Some sj ->
 107                 Reg.Set.iter (identify_sub si sj)
 108                              (Reg.add_set_array instr.live instr.arg)
 109           done;
 110           sub
 111     end in
 112   find_one_subst 0
 113
 114 (* First pass: rename registers at reload points *)
 115
 116 let exit_subst = ref []
 117
 118 let find_exit_subst k =
 119   try
 120     List.assoc k !exit_subst with
 121   | Not_found -> Misc.fatal_error "Split.find_exit_subst"
 122
 123 let rec rename i sub =
 124   match i.desc with
 125     Iend ->
 126       (i, sub)
 127   | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
 128       (instr_cons i.desc (subst_regs i.arg sub) [||] i.next,
 129        None)
 130   | Iop Ireload when i.res.(0).loc = Unknown ->
 131       begin match sub with
 132         None -> rename i.next sub
 133       | Some s ->
 134           let oldr = i.res.(0) in
 135           let newr = Reg.clone i.res.(0) in
 136           let (new_next, sub_next) =
 137             rename i.next (Some(Reg.Map.add oldr newr s)) in
 138           (instr_cons i.desc i.arg [|newr|] new_next,
 139            sub_next)
 140       end
 141   | Iop _ ->
 142       let (new_next, sub_next) = rename i.next sub in
 143       (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub)
 144                         i.dbg new_next,
 145        sub_next)
 146   | Iifthenelse(tst, ifso, ifnot) ->
 147       let (new_ifso, sub_ifso) = rename ifso sub in
 148       let (new_ifnot, sub_ifnot) = rename ifnot sub in
 149       let (new_next, sub_next) =
 150         rename i.next (merge_substs sub_ifso sub_ifnot i.next) in
 151       (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot))
 152                   (subst_regs i.arg sub) [||] new_next,
 153        sub_next)
 154   | Iswitch(index, cases) ->
 155       let new_sub_cases = Array.map (fun c -> rename c sub) cases in
 156       let sub_merge =
 157         merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in
 158       let (new_next, sub_next) = rename i.next sub_merge in
 159       (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases))
 160                   (subst_regs i.arg sub) [||] new_next,
 161        sub_next)
 162   | Iloop(body) ->
 163       let (new_body, sub_body) = rename body sub in
 164       let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in
 165       (instr_cons (Iloop(new_body)) [||] [||] new_next,
 166        sub_next)
 167   | Icatch(nfail, body, handler) ->
 168       let new_subst = ref None in
 169       exit_subst := (nfail, new_subst) :: !exit_subst ;
 170       let (new_body, sub_body) = rename body sub in
 171       let sub_entry_handler = !new_subst in
 172       exit_subst := List.tl !exit_subst;
 173       let (new_handler, sub_handler) = rename handler sub_entry_handler in
 174       let (new_next, sub_next) =
 175         rename i.next (merge_substs sub_body sub_handler i.next) in
 176       (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next,
 177        sub_next)
 178   | Iexit nfail ->
 179       let r = find_exit_subst nfail in
 180       r := merge_substs !r sub i;
 181       (i, None)
 182   | Itrywith(body, handler) ->
 183       let (new_body, sub_body) = rename body sub in
 184       let (new_handler, sub_handler) = rename handler sub in
 185       let (new_next, sub_next) =
 186         rename i.next (merge_substs sub_body sub_handler i.next) in
 187       (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next,
 188        sub_next)
 189   | Iraise ->
 190       (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
 191        None)
 192
 193 (* Second pass: replace registers by their final representatives *)
 194
 195 let set_repres i =
 196   instr_iter (fun i -> repres_regs i.arg; repres_regs i.res) i
 197
 198 (* Entry point *)
 199
 200 let fundecl f =
 201   equiv_classes := Reg.Map.empty;
 202   let new_args = Array.copy f.fun_args in
 203   let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in
 204   repres_regs new_args;
 205   set_repres new_body;
 206   equiv_classes := Reg.Map.empty;
 207   { fun_name = f.fun_name;
 208     fun_args = new_args;
 209     fun_body = new_body;
 210     fun_fast = f.fun_fast }