asmcomp/linearize.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 (* Transformation of Mach code into a list of pseudo-instructions. *)
  16
  17 open Reg
  18 open Mach
  19
  20 type label = int
  21
  22 let label_counter = ref 99
  23
  24 let new_label() = incr label_counter; !label_counter
  25
  26 type instruction =
  27   { mutable desc: instruction_desc;
  28     mutable next: instruction;
  29     arg: Reg.t array;
  30     res: Reg.t array;
  31     dbg: Debuginfo.t;
  32     live: Reg.Set.t }
  33
  34 and instruction_desc =
  35     Lend
  36   | Lop of operation
  37   | Lreloadretaddr
  38   | Lreturn
  39   | Llabel of label
  40   | Lbranch of label
  41   | Lcondbranch of test * label
  42   | Lcondbranch3 of label option * label option * label option
  43   | Lswitch of label array
  44   | Lsetuptrap of label
  45   | Lpushtrap
  46   | Lpoptrap
  47   | Lraise
  48
  49 let has_fallthrough = function
  50   | Lreturn | Lbranch _ | Lswitch _ | Lraise
  51   | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false
  52   | _ -> true
  53
  54 type fundecl =
  55   { fun_name: string;
  56     fun_body: instruction;
  57     fun_fast: bool }
  58
  59 (* Invert a test *)
  60
  61 let invert_integer_test = function
  62     Isigned cmp -> Isigned(Cmm.negate_comparison cmp)
  63   | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp)
  64
  65 let invert_test = function
  66     Itruetest -> Ifalsetest
  67   | Ifalsetest -> Itruetest
  68   | Iinttest(cmp) -> Iinttest(invert_integer_test cmp)
  69   | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n)
  70   | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg)
  71   | Ieventest -> Ioddtest
  72   | Ioddtest -> Ieventest
  73
  74 (* The "end" instruction *)
  75
  76 let rec end_instr =
  77   { desc = Lend;
  78     next = end_instr;
  79     arg = [||];
  80     res = [||];
  81     dbg = Debuginfo.none;
  82     live = Reg.Set.empty }
  83
  84 (* Cons an instruction (live, debug empty) *)
  85
  86 let instr_cons d a r n =
  87   { desc = d; next = n; arg = a; res = r;
  88     dbg = Debuginfo.none; live = Reg.Set.empty }
  89
  90 (* Cons a simple instruction (arg, res, live empty) *)
  91
  92 let cons_instr d n =
  93   { desc = d; next = n; arg = [||]; res = [||];
  94     dbg = Debuginfo.none; live = Reg.Set.empty }
  95
  96 (* Build an instruction with arg, res, dbg, live taken from
  97    the given Mach.instruction *)
  98
  99 let copy_instr d i n =
 100   { desc = d; next = n;
 101     arg = i.Mach.arg; res = i.Mach.res;
 102     dbg = i.Mach.dbg; live = i.Mach.live }
 103
 104 (*
 105    Label the beginning of the given instruction sequence.
 106    - If the sequence starts with a branch, jump over it.
 107    - If the sequence is the end, (tail call position), just do nothing
 108 *)
 109
 110 let get_label n = match n.desc with
 111     Lbranch lbl -> (lbl, n)
 112   | Llabel lbl -> (lbl, n)
 113   | Lend -> (-1, n)
 114   | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n)
 115
 116 (* Check the fallthrough label *)
 117 let check_label n = match n.desc with
 118   | Lbranch lbl -> lbl
 119   | Llabel lbl -> lbl
 120   | _ -> -1
 121
 122 (* Discard all instructions up to the next label.
 123    This function is to be called before adding a non-terminating
 124    instruction. *)
 125
 126 let rec discard_dead_code n =
 127   match n.desc with
 128     Lend -> n
 129   | Llabel _ -> n
 130 (* Do not discard Lpoptrap or Istackoffset instructions,
 131    as this may cause a stack imbalance later during assembler generation. *)
 132   | Lpoptrap -> n
 133   | Lop(Istackoffset _) -> n
 134   | _ -> discard_dead_code n.next
 135
 136 (*
 137    Add a branch in front of a continuation.
 138    Discard dead code in the continuation.
 139    Does not insert anything if we're just falling through
 140    or if we jump to dead code after the end of function (lbl=-1)
 141 *)
 142
 143 let add_branch lbl n =
 144   if lbl >= 0 then
 145     let n1 = discard_dead_code n in
 146     match n1.desc with
 147     | Llabel lbl1 when lbl1 = lbl -> n1
 148     | _ -> cons_instr (Lbranch lbl) n1
 149   else
 150     discard_dead_code n
 151
 152 (* Current labels for exit handler *)
 153
 154 let exit_label = ref []
 155
 156 let find_exit_label k =
 157   try
 158     List.assoc k !exit_label
 159   with
 160   | Not_found -> Misc.fatal_error "Linearize.find_exit_label"
 161
 162 let is_next_catch n = match !exit_label with
 163 | (n0,_)::_  when n0=n -> true
 164 | _ -> false
 165
 166 (* Linearize an instruction [i]: add it in front of the continuation [n] *)
 167
 168 let rec linear i n =
 169   match i.Mach.desc with
 170     Iend -> n
 171   | Iop(Itailcall_ind | Itailcall_imm _ as op) ->
 172       copy_instr (Lop op) i (discard_dead_code n)
 173   | Iop(Imove | Ireload | Ispill)
 174     when i.Mach.arg.(0).loc = i.Mach.res.(0).loc ->
 175       linear i.Mach.next n
 176   | Iop op ->
 177       copy_instr (Lop op) i (linear i.Mach.next n)
 178   | Ireturn ->
 179       let n1 = copy_instr Lreturn i (discard_dead_code n) in
 180       if !Proc.contains_calls
 181       then cons_instr Lreloadretaddr n1
 182       else n1
 183   | Iifthenelse(test, ifso, ifnot) ->
 184       let n1 = linear i.Mach.next n in
 185       begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with
 186         Iend, _, Lbranch lbl ->
 187           copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
 188       | _, Iend, Lbranch lbl ->
 189           copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
 190       | Iexit nfail1, Iexit nfail2, _
 191             when is_next_catch nfail1 ->
 192           let lbl2 = find_exit_label nfail2 in
 193           copy_instr
 194             (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1)
 195       | Iexit nfail, _, _ ->
 196           let n2 = linear ifnot n1
 197           and lbl = find_exit_label nfail in
 198           copy_instr (Lcondbranch(test, lbl)) i n2
 199       | _,  Iexit nfail, _ ->
 200           let n2 = linear ifso n1 in
 201           let lbl = find_exit_label nfail in
 202           copy_instr (Lcondbranch(invert_test test, lbl)) i n2
 203       | Iend, _, _ ->
 204           let (lbl_end, n2) = get_label n1 in
 205           copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2)
 206       | _,  Iend, _ ->
 207           let (lbl_end, n2) = get_label n1 in
 208           copy_instr (Lcondbranch(invert_test test, lbl_end)) i
 209                      (linear ifso n2)
 210       | _, _, _ ->
 211         (* Should attempt branch prediction here *)
 212           let (lbl_end, n2) = get_label n1 in
 213           let (lbl_else, nelse) = get_label (linear ifnot n2) in
 214           copy_instr (Lcondbranch(invert_test test, lbl_else)) i
 215             (linear ifso (add_branch lbl_end nelse))
 216       end
 217   | Iswitch(index, cases) ->
 218       let lbl_cases = Array.create (Array.length cases) 0 in
 219       let (lbl_end, n1) = get_label(linear i.Mach.next n) in
 220       let n2 = ref (discard_dead_code n1) in
 221       for i = Array.length cases - 1 downto 0 do
 222         let (lbl_case, ncase) =
 223                 get_label(linear cases.(i) (add_branch lbl_end !n2)) in
 224         lbl_cases.(i) <- lbl_case;
 225         n2 := discard_dead_code ncase
 226       done;
 227       (* Switches with 1 and 2 branches have been eliminated earlier.
 228          Here, we do something for switches with 3 branches. *)
 229       if Array.length index = 3 then begin
 230         let fallthrough_lbl = check_label !n2 in
 231         let find_label n =
 232           let lbl = lbl_cases.(index.(n)) in
 233           if lbl = fallthrough_lbl then None else Some lbl in
 234         copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2))
 235                    i !n2
 236       end else
 237         copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2
 238   | Iloop body ->
 239       let lbl_head = new_label() in
 240       let n1 = linear i.Mach.next n in
 241       let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
 242       cons_instr (Llabel lbl_head) n2
 243   | Icatch(io, body, handler) ->
 244       let (lbl_end, n1) = get_label(linear i.Mach.next n) in
 245       let (lbl_handler, n2) = get_label(linear handler n1) in
 246       exit_label := (io, lbl_handler) :: !exit_label ;
 247       let n3 = linear body (add_branch lbl_end n2) in
 248       exit_label := List.tl !exit_label;
 249       n3
 250   | Iexit nfail ->
 251       let n1 = linear i.Mach.next n in
 252       let lbl = find_exit_label nfail in
 253       add_branch lbl n1
 254   | Itrywith(body, handler) ->
 255       let (lbl_join, n1) = get_label (linear i.Mach.next n) in
 256       let (lbl_body, n2) =
 257         get_label (cons_instr Lpushtrap
 258                     (linear body (cons_instr Lpoptrap n1))) in
 259       cons_instr (Lsetuptrap lbl_body)
 260         (linear handler (add_branch lbl_join n2))
 261   | Iraise ->
 262       copy_instr Lraise i (discard_dead_code n)
 263
 264 let fundecl f =
 265   { fun_name = f.Mach.fun_name;
 266     fun_body = linear f.Mach.fun_body end_instr;
 267     fun_fast = f.Mach.fun_fast }