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