1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Mach
open Linear
module Make (T : Branch_relaxation_intf.S) = struct
let label_map f =
let map = Hashtbl.create 37 in
let rec fill_map pc instr =
match instr.desc with
| Lend -> (pc, map)
| Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next
| op -> fill_map (pc + T.instr_size f op) instr.next
in
fill_map 0 f.fun_body
let branch_overflows map pc_branch lbl_dest max_branch_offset =
let pc_dest = Hashtbl.find map lbl_dest in
let delta = pc_dest - (pc_branch + T.offset_pc_at_branch) in
delta <= -max_branch_offset || delta >= max_branch_offset
let opt_branch_overflows map pc_branch opt_lbl_dest max_branch_offset =
match opt_lbl_dest with
| None -> false
| Some lbl_dest ->
branch_overflows map pc_branch lbl_dest max_branch_offset
let instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc =
match T.Cond_branch.classify_instr instr.desc with
| None -> false
| Some branch ->
let max_branch_offset =
(* Remember to cut some slack for multi-word instructions (in the
[Linear] sense of the word) where the branch can be anywhere in
the middle. 12 words of slack is plenty. *)
T.Cond_branch.max_displacement branch - 12
in
match instr.desc with
| Lop (Ialloc _)
| Lop (Ipoll { return_label = None })
| Lop (Iintop (Icheckbound))
| Lop (Iintop_imm (Icheckbound, _))
| Lop (Ispecific _) ->
(* We assume that any branches eligible for relaxation generated
by these instructions only branch forward. We further assume
that any of these may branch to an out-of-line code block. *)
code_size + max_out_of_line_code_offset - pc >= max_branch_offset
| Lcondbranch (_, lbl) ->
branch_overflows map pc lbl max_branch_offset
| Lcondbranch3 (lbl0, lbl1, lbl2) ->
opt_branch_overflows map pc lbl0 max_branch_offset
|| opt_branch_overflows map pc lbl1 max_branch_offset
|| opt_branch_overflows map pc lbl2 max_branch_offset
| Lop (Ipoll { return_label = Some lbl }) ->
(* A poll-and-branch instruction can branch to the label lbl,
but also to an out-of-line code block. *)
code_size + max_out_of_line_code_offset - pc >= max_branch_offset
|| branch_overflows map pc lbl max_branch_offset
| _ ->
Misc.fatal_error "Unsupported instruction for branch relaxation"
let fixup_branches ~code_size ~max_out_of_line_code_offset map f =
let expand_optbranch lbl n arg next =
match lbl with
| None -> next
| Some l ->
instr_cons (Lcondbranch (Iinttest_imm (Isigned Cmm.Ceq, n), l))
arg [||] next
in
let rec fixup did_fix pc instr =
match instr.desc with
| Lend -> did_fix
| _ ->
let overflows =
instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc
in
if not overflows then
fixup did_fix (pc + T.instr_size f instr.desc) instr.next
else
match instr.desc with
| Lop (Ipoll { return_label }) ->
instr.desc <- T.relax_poll ~return_label;
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lop (Ialloc { bytes = num_bytes; dbginfo }) ->
instr.desc <- T.relax_allocation ~num_bytes ~dbginfo;
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lop (Iintop (Icheckbound)) ->
instr.desc <- T.relax_intop_checkbound ();
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lop (Iintop_imm (Icheckbound, bound)) ->
instr.desc
<- T.relax_intop_imm_checkbound ~bound;
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lop (Ispecific specific) ->
instr.desc <- T.relax_specific_op specific;
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lcondbranch (test, lbl) ->
let lbl2 = Cmm.new_label() in
let cont =
instr_cons (Lbranch lbl) [||] [||]
(instr_cons (Llabel lbl2) [||] [||] instr.next)
in
instr.desc <- Lcondbranch (invert_test test, lbl2);
instr.next <- cont;
fixup true (pc + T.instr_size f instr.desc) instr.next
| Lcondbranch3 (lbl0, lbl1, lbl2) ->
let cont =
expand_optbranch lbl0 0 instr.arg
(expand_optbranch lbl1 1 instr.arg
(expand_optbranch lbl2 2 instr.arg instr.next))
in
instr.desc <- cont.desc;
instr.next <- cont.next;
fixup true pc instr
| _ ->
(* Any other instruction has already been rejected in
[instr_overflows] above.
We can *never* get here. *)
assert false
in
fixup false 0 f.fun_body
(* Iterate branch expansion till all conditional branches are OK *)
let rec relax f ~max_out_of_line_code_offset =
let min_of_max_branch_offsets =
List.fold_left (fun min_of_max_branch_offsets branch ->
Int.min min_of_max_branch_offsets
(T.Cond_branch.max_displacement branch))
max_int T.Cond_branch.all
in
let (code_size, map) = label_map f in
if code_size >= min_of_max_branch_offsets
&& fixup_branches ~code_size ~max_out_of_line_code_offset map f
then relax f ~max_out_of_line_code_offset
else ()
end
|
