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

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1997 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 7812 2007-01-29 12:11:18Z xleroy $ *)
  14
  15 (* Instruction selection for the Intel x86 *)
  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 ->
  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 (* C functions to be turned into Ifloatspecial instructions if -ffast-math *)
  77
  78 let inline_float_ops =
  79   ["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"]
  80
  81 (* Estimate number of float temporaries needed to evaluate expression
  82    (Ershov's algorithm) *)
  83
  84 let rec float_needs = function
  85     Cop((Cnegf | Cabsf), [arg]) ->
  86       float_needs arg
  87   | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) ->
  88       let n1 = float_needs arg1 in
  89       let n2 = float_needs arg2 in
  90       if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
  91   | Cop(Cextcall(fn, ty_res, alloc, dbg), args)
  92     when !fast_math && List.mem fn inline_float_ops ->
  93       begin match args with
  94         [arg] -> float_needs arg
  95       | [arg1; arg2] -> max (float_needs arg2 + 1) (float_needs arg1)
  96       | _ -> assert false
  97       end
  98   | _ ->
  99       1
 100
 101 (* Special constraints on operand and result registers *)
 102
 103 exception Use_default
 104
 105 let eax = phys_reg 0
 106 let ecx = phys_reg 2
 107 let edx = phys_reg 3
 108 let tos = phys_reg 100
 109
 110 let pseudoregs_for_operation op arg res =
 111   match op with
 112   (* Two-address binary operations *)
 113     Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) ->
 114       ([|res.(0); arg.(1)|], res, false)
 115   (* Two-address unary operations *)
 116   | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) ->
 117       (res, res, false)
 118   (* For shifts with variable shift count, second arg must be in ecx *)
 119   | Iintop(Ilsl|Ilsr|Iasr) ->
 120       ([|res.(0); ecx|], res, false)
 121   (* For div and mod, first arg must be in eax, edx is clobbered,
 122      and result is in eax or edx respectively.
 123      Keep it simple, just force second argument in ecx. *)
 124   | Iintop(Idiv) ->
 125       ([| eax; ecx |], [| eax |], true)
 126   | Iintop(Imod) ->
 127       ([| eax; ecx |], [| edx |], true)
 128   (* For mod with immediate operand, arg must not be in eax.
 129      Keep it simple, force it in edx. *)
 130   | Iintop_imm(Imod, _) ->
 131       ([| edx |], [| edx |], true)
 132   (* For floating-point operations and floating-point loads,
 133      the result is always left at the top of the floating-point stack *)
 134   | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
 135   | Ifloatofint | Iload((Single | Double | Double_u), _)
 136   | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _, _) | Ifloatspecial _) ->
 137       (arg, [| tos |], false)           (* don't move it immediately *)
 138   (* For storing a byte, the argument must be in eax...edx.
 139      (But for a short, any reg will do!)
 140      Keep it simple, just force the argument to be in edx. *)
 141   | Istore((Byte_unsigned | Byte_signed), addr) ->
 142       let newarg = Array.copy arg in
 143       newarg.(0) <- edx;
 144       (newarg, res, false)
 145   (* Other instructions are regular *)
 146   | _ -> raise Use_default
 147
 148 let chunk_double = function
 149     Single -> false
 150   | Double -> true
 151   | Double_u -> true
 152   | _ -> assert false
 153
 154 (* The selector class *)
 155
 156 class selector = object (self)
 157
 158 inherit Selectgen.selector_generic as super
 159
 160 method is_immediate (n : int) = true
 161
 162 method is_simple_expr e =
 163   match e with
 164   | Cop(Cextcall(fn, _, alloc, _), args)
 165     when !fast_math && List.mem fn inline_float_ops ->
 166       (* inlined float ops are simple if their arguments are *)
 167       List.for_all self#is_simple_expr args
 168   | _ ->
 169       super#is_simple_expr e
 170
 171 method select_addressing exp =
 172   match select_addr exp with
 173     (Asymbol s, d) ->
 174       (Ibased(s, d), Ctuple [])
 175   | (Alinear e, d) ->
 176       (Iindexed d, e)
 177   | (Aadd(e1, e2), d) ->
 178       (Iindexed2 d, Ctuple[e1; e2])
 179   | (Ascale(e, scale), d) ->
 180       (Iscaled(scale, d), e)
 181   | (Ascaledadd(e1, e2, scale), d) ->
 182       (Iindexed2scaled(scale, d), Ctuple[e1; e2])
 183
 184 method select_store addr exp =
 185   match exp with
 186     Cconst_int n ->
 187       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
 188   | Cconst_natint n ->
 189       (Ispecific(Istore_int(n, addr)), Ctuple [])
 190   | Cconst_pointer n ->
 191       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
 192   | Cconst_natpointer n ->
 193       (Ispecific(Istore_int(n, addr)), Ctuple [])
 194   | Cconst_symbol s ->
 195       (Ispecific(Istore_symbol(s, addr)), Ctuple [])
 196   | _ ->
 197       super#select_store addr exp
 198
 199 method select_operation op args =
 200   match op with
 201   (* Recognize the LEA instruction *)
 202     Caddi | Cadda | Csubi | Csuba ->
 203       begin match self#select_addressing (Cop(op, args)) with
 204         (Iindexed d, _) -> super#select_operation op args
 205       | (Iindexed2 0, _) -> super#select_operation op args
 206       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
 207       end
 208   (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
 209   | Cdivi ->
 210       begin match args with
 211         [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
 212           (Iintop_imm(Idiv, n), [arg1])
 213       | _ -> (Iintop Idiv, args)
 214       end
 215   | Cmodi ->
 216       begin match args with
 217         [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
 218           (Iintop_imm(Imod, n), [arg1])
 219       | _ -> (Iintop Imod, args)
 220       end
 221   (* Recognize float arithmetic with memory.
 222      In passing, apply Ershov's algorithm to reduce stack usage *)
 223   | Caddf ->
 224       self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
 225   | Csubf ->
 226       self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args
 227   | Cmulf ->
 228       self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
 229   | Cdivf ->
 230       self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args
 231   (* Recognize store instructions *)
 232   | Cstore Word ->
 233       begin match args with
 234         [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
 235         when loc = loc' ->
 236           let (addr, arg) = self#select_addressing loc in
 237           (Ispecific(Ioffset_loc(n, addr)), [arg])
 238       | _ ->
 239           super#select_operation op args
 240       end
 241   (* Recognize inlined floating point operations *)
 242   | Cextcall(fn, ty_res, false, dbg)
 243     when !fast_math && List.mem fn inline_float_ops ->
 244       (Ispecific(Ifloatspecial fn), args)
 245   (* Default *)
 246   | _ -> super#select_operation op args
 247
 248 (* Recognize float arithmetic with mem *)
 249
 250 method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
 251   match args with
 252     [arg1; Cop(Cload chunk, [loc2])] ->
 253       let (addr, arg2) = self#select_addressing loc2 in
 254       (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)),
 255                  [arg1; arg2])
 256   | [Cop(Cload chunk, [loc1]); arg2] ->
 257       let (addr, arg1) = self#select_addressing loc1 in
 258       (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)),
 259                  [arg2; arg1])
 260   | [arg1; arg2] ->
 261       (* Evaluate bigger subexpression first to minimize stack usage.
 262          Because of right-to-left evaluation, rightmost arg is evaluated
 263          first *)
 264       if float_needs arg1 <= float_needs arg2
 265       then (regular_op, [arg1; arg2])
 266       else (reversed_op, [arg2; arg1])
 267   | _ ->
 268       fatal_error "Proc_i386: select_floatarith"
 269
 270 (* Deal with register constraints *)
 271
 272 method insert_op_debug op dbg rs rd =
 273   try
 274     let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in
 275     self#insert_moves rs rsrc;
 276     self#insert_debug (Iop op) dbg rsrc rdst;
 277     if move_res then begin
 278       self#insert_moves rdst rd;
 279       rd
 280     end else
 281       rdst
 282   with Use_default ->
 283     super#insert_op_debug op dbg rs rd
 284
 285 method insert_op op rs rd =
 286   self#insert_op_debug op Debuginfo.none rs rd
 287
 288 (* Selection of push instructions for external calls *)
 289
 290 method select_push exp =
 291   match exp with
 292     Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
 293   | Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple [])
 294   | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
 295   | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
 296   | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
 297   | Cop(Cload Word, [loc]) ->
 298       let (addr, arg) = self#select_addressing loc in
 299       (Ispecific(Ipush_load addr), arg)
 300   | Cop(Cload Double_u, [loc]) ->
 301       let (addr, arg) = self#select_addressing loc in
 302       (Ispecific(Ipush_load_float addr), arg)
 303   | _ -> (Ispecific(Ipush), exp)
 304
 305 method emit_extcall_args env args =
 306   let rec size_pushes = function
 307   | [] -> 0
 308   | e :: el -> Selectgen.size_expr env e + size_pushes el in
 309   let sz1 = size_pushes args in
 310   let sz2 = Misc.align sz1 stack_alignment in
 311   let rec emit_pushes = function
 312   | [] ->
 313       if sz2 > sz1 then
 314         self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||]
 315   | e :: el ->
 316       emit_pushes el;
 317       let (op, arg) = self#select_push e in
 318       match self#emit_expr env arg with
 319       | None -> ()
 320       | Some r -> self#insert (Iop op) r [||] in
 321   emit_pushes args;
 322   ([||], sz2)
 323
 324 end
 325
 326 let fundecl f = (new selector)#emit_fundecl f
 327