l4/pkg/ocaml/contrib/asmcomp/amd64/selection.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2000 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: selection.ml 9114 2008-10-29 14:32:01Z xleroy $ *)
  14
  15 (* Instruction selection for the AMD64 *)
  16
  17 open Misc
  18 open Arch
  19 open Proc
  20 open Cmm
  21 open Reg
  22 open Mach
  23
  24 (* Auxiliary for recognizing addressing modes *)
  25
  26 type addressing_expr =
  27     Asymbol of string
  28   | Alinear of expression
  29   | Aadd of expression * expression
  30   | Ascale of expression * int
  31   | Ascaledadd of expression * expression * int
  32
  33 let rec select_addr exp =
  34   match exp with
  35     Cconst_symbol s when not !Clflags.dlcode ->
  36       (Asymbol s, 0)
  37   | Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
  38       let (a, n) = select_addr arg in (a, n + m)
  39   | Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
  40       let (a, n) = select_addr arg in (a, n - m)
  41   | Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
  42       let (a, n) = select_addr arg in (a, n + m)
  43   | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
  44       begin match select_addr arg with
  45         (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
  46       | _ -> (Alinear exp, 0)
  47       end
  48   | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
  49       begin match select_addr arg with
  50         (Alinear e, n) -> (Ascale(e, mult), n * mult)
  51       | _ -> (Alinear exp, 0)
  52       end
  53   | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
  54       begin match select_addr arg with
  55         (Alinear e, n) -> (Ascale(e, mult), n * mult)
  56       | _ -> (Alinear exp, 0)
  57       end
  58   | Cop((Caddi | Cadda), [arg1; arg2]) ->
  59       begin match (select_addr arg1, select_addr arg2) with
  60           ((Alinear e1, n1), (Alinear e2, n2)) ->
  61               (Aadd(e1, e2), n1 + n2)
  62         | ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
  63               (Ascaledadd(e1, e2, scale), n1 + n2)
  64         | ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
  65               (Ascaledadd(e2, e1, scale), n1 + n2)
  66         | (_, (Ascale(e2, scale), n2)) ->
  67               (Ascaledadd(arg1, e2, scale), n2)
  68         | ((Ascale(e1, scale), n1), _) ->
  69               (Ascaledadd(arg2, e1, scale), n1)
  70         | _ ->
  71               (Aadd(arg1, arg2), 0)
  72       end
  73   | arg ->
  74       (Alinear arg, 0)
  75
  76 (* Special constraints on operand and result registers *)
  77
  78 exception Use_default
  79
  80 let rax = phys_reg 0
  81 let rcx = phys_reg 5
  82 let rdx = phys_reg 4
  83
  84 let pseudoregs_for_operation op arg res =
  85   match op with
  86   (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
  87     Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf ->
  88       ([|res.(0); arg.(1)|], res)
  89   (* One-address unary operations: arg.(0) and res.(0) must be the same *)
  90   | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _)
  91   | Iabsf | Inegf ->
  92       (res, res)
  93   | Ispecific(Ifloatarithmem(_,_)) ->
  94       let arg' = Array.copy arg in
  95       arg'.(0) <- res.(0);
  96       (arg', res)
  97   (* For shifts with variable shift count, second arg must be in rcx *)
  98   | Iintop(Ilsl|Ilsr|Iasr) ->
  99       ([|res.(0); rcx|], res)
 100   (* For div and mod, first arg must be in rax, rdx is clobbered,
 101      and result is in rax or rdx respectively.
 102      Keep it simple, just force second argument in rcx. *)
 103   | Iintop(Idiv) ->
 104       ([| rax; rcx |], [| rax |])
 105   | Iintop(Imod) ->
 106       ([| rax; rcx |], [| rdx |])
 107   (* For div and mod with immediate operand, arg must not be in rax.
 108      Keep it simple, force it in rdx. *)
 109   | Iintop_imm((Idiv|Imod), _) ->
 110       ([| rdx |], [| rdx |])
 111   (* Other instructions are regular *)
 112   | _ -> raise Use_default
 113
 114 (* The selector class *)
 115
 116 class selector = object (self)
 117
 118 inherit Selectgen.selector_generic as super
 119
 120 method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
 121
 122 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 123
 124 method select_addressing exp =
 125   let (a, d) = select_addr exp in
 126   (* PR#4625: displacement must be a signed 32-bit immediate *)
 127   if d < -0x8000_0000 || d > 0x7FFF_FFFF
 128   then (Iindexed 0, exp)
 129   else match a with
 130     | Asymbol s ->
 131         (Ibased(s, d), Ctuple [])
 132     | Alinear e ->
 133         (Iindexed d, e)
 134     | Aadd(e1, e2) ->
 135         (Iindexed2 d, Ctuple[e1; e2])
 136     | Ascale(e, scale) ->
 137         (Iscaled(scale, d), e)
 138     | Ascaledadd(e1, e2, scale) ->
 139         (Iindexed2scaled(scale, d), Ctuple[e1; e2])
 140
 141 method select_store addr exp =
 142   match exp with
 143     Cconst_int n when self#is_immediate n ->
 144       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
 145   | Cconst_natint n when self#is_immediate_natint n ->
 146       (Ispecific(Istore_int(n, addr)), Ctuple [])
 147   | Cconst_pointer n when self#is_immediate n ->
 148       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
 149   | Cconst_natpointer n when self#is_immediate_natint n ->
 150       (Ispecific(Istore_int(n, addr)), Ctuple [])
 151   | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) ->
 152       (Ispecific(Istore_symbol(s, addr)), Ctuple [])
 153   | _ ->
 154       super#select_store addr exp
 155
 156 method select_operation op args =
 157   match op with
 158   (* Recognize the LEA instruction *)
 159     Caddi | Cadda | Csubi | Csuba ->
 160       begin match self#select_addressing (Cop(op, args)) with
 161         (Iindexed d, _) -> super#select_operation op args
 162       | (Iindexed2 0, _) -> super#select_operation op args
 163       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
 164       end
 165   (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
 166   | Cdivi ->
 167       begin match args with
 168         [arg1; Cconst_int n] when self#is_immediate n
 169                                && n = 1 lsl (Misc.log2 n) ->
 170           (Iintop_imm(Idiv, n), [arg1])
 171       | _ -> (Iintop Idiv, args)
 172       end
 173   | Cmodi ->
 174       begin match args with
 175         [arg1; Cconst_int n] when self#is_immediate n
 176                                && n = 1 lsl (Misc.log2 n) ->
 177           (Iintop_imm(Imod, n), [arg1])
 178       | _ -> (Iintop Imod, args)
 179       end
 180   (* Recognize float arithmetic with memory. *)
 181   | Caddf ->
 182       self#select_floatarith true Iaddf Ifloatadd args
 183   | Csubf ->
 184       self#select_floatarith false Isubf Ifloatsub args
 185   | Cmulf ->
 186       self#select_floatarith true Imulf Ifloatmul args
 187   | Cdivf ->
 188       self#select_floatarith false Idivf Ifloatdiv args
 189   (* Recognize store instructions *)
 190   | Cstore Word ->
 191       begin match args with
 192         [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
 193         when loc = loc' && self#is_immediate n ->
 194           let (addr, arg) = self#select_addressing loc in
 195           (Ispecific(Ioffset_loc(n, addr)), [arg])
 196       | _ ->
 197           super#select_operation op args
 198       end
 199   | _ -> super#select_operation op args
 200
 201 (* Recognize float arithmetic with mem *)
 202
 203 method select_floatarith commutative regular_op mem_op args =
 204   match args with
 205     [arg1; Cop(Cload (Double|Double_u), [loc2])] ->
 206       let (addr, arg2) = self#select_addressing loc2 in
 207       (Ispecific(Ifloatarithmem(mem_op, addr)),
 208                  [arg1; arg2])
 209   | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative ->
 210       let (addr, arg1) = self#select_addressing loc1 in
 211       (Ispecific(Ifloatarithmem(mem_op, addr)),
 212                  [arg2; arg1])
 213   | [arg1; arg2] ->
 214       (regular_op, [arg1; arg2])
 215   | _ ->
 216       assert false
 217
 218 (* Deal with register constraints *)
 219
 220 method insert_op_debug op dbg rs rd =
 221   try
 222     let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
 223     self#insert_moves rs rsrc;
 224     self#insert_debug (Iop op) dbg rsrc rdst;
 225     self#insert_moves rdst rd;
 226     rd
 227   with Use_default ->
 228     super#insert_op_debug op dbg rs rd
 229
 230 method insert_op op rs rd =
 231   self#insert_op_debug op Debuginfo.none rs rd
 232
 233 end
 234
 235 let fundecl f = (new selector)#emit_fundecl f