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