l4/pkg/ocaml/contrib/asmcomp/amd64/emit_nt.mlp

   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: emit_nt.mlp 8768 2008-01-11 16:13:18Z doligez $ *)
  14
  15 (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *)
  16
  17 module StringSet =
  18   Set.Make(struct type t = string let compare = compare end)
  19
  20 open Misc
  21 open Cmm
  22 open Arch
  23 open Proc
  24 open Reg
  25 open Mach
  26 open Linearize
  27 open Emitaux
  28
  29 (* Tradeoff between code size and code speed *)
  30
  31 let fastcode_flag = ref true
  32
  33 let stack_offset = ref 0
  34
  35 (* Layout of the stack frame *)
  36
  37 let frame_required () =
  38   !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
  39
  40 let frame_size () =                     (* includes return address *)
  41   if frame_required() then begin
  42     let sz =
  43       (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8)
  44     in Misc.align sz 16
  45   end else
  46     !stack_offset + 8
  47
  48 let slot_offset loc cl =
  49   match loc with
  50     Incoming n -> frame_size() + n
  51   | Local n ->
  52       if cl = 0
  53       then !stack_offset + n * 8
  54       else !stack_offset + (num_stack_slots.(0) + n) * 8
  55   | Outgoing n -> n
  56
  57 (* Output a 32 bit integer in hex *)
  58
  59 let emit_int32 n = emit_printf "0%lxh" n
  60
  61 (* Symbols *)
  62
  63 let emit_symbol s =
  64   Emitaux.emit_symbol '$' s
  65
  66 (* Record symbols used and defined - at the end generate extern for those
  67    used but not defined *)
  68
  69 let symbols_defined = ref StringSet.empty
  70 let symbols_used = ref StringSet.empty
  71
  72 let add_def_symbol s =
  73   symbols_defined := StringSet.add s !symbols_defined
  74
  75 let add_used_symbol s =
  76   symbols_used := StringSet.add s !symbols_used
  77
  78 (* Output a label *)
  79
  80 let emit_label lbl =
  81   emit_string "L"; emit_int lbl
  82
  83 (* Output a .align directive. *)
  84
  85 let emit_align n =
  86   `     ALIGN   {emit_int n}\n`
  87
  88 let emit_Llabel fallthrough lbl =
  89   if not fallthrough && !fastcode_flag then emit_align 4;
  90   emit_label lbl
  91
  92 (* Output a pseudo-register *)
  93
  94 let emit_reg = function
  95     { loc = Reg r } ->
  96       emit_string (register_name r)
  97   | { loc = Stack s; typ = Float } as r ->
  98       let ofs = slot_offset s (register_class r) in
  99       `REAL8 PTR {emit_int ofs}[rsp]`
 100   | { loc = Stack s; typ = _ } as r ->
 101       let ofs = slot_offset s (register_class r) in
 102       `QWORD PTR {emit_int ofs}[rsp]`
 103   | { loc = Unknown } ->
 104       assert false
 105
 106 (* Output a reference to the lower 8, 16 or 32 bits of a register *)
 107
 108 let reg_low_8_name =
 109   [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b";
 110      "r10b"; "r11b"; "bpl"; "r12b"; "r13b" |]
 111 let reg_low_16_name =
 112   [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w";
 113      "r10w"; "r11w"; "bp"; "r12w"; "r13w" |]
 114 let reg_low_32_name =
 115   [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d";
 116      "r10d"; "r11d"; "ebp"; "r12d"; "r13d" |]
 117
 118 let emit_subreg tbl pref r =
 119   match r.loc with
 120     Reg r when r < 13 ->
 121       emit_string tbl.(r)
 122   | Stack s ->
 123       let ofs = slot_offset s (register_class r) in
 124       `{emit_string pref} PTR {emit_int ofs}[rsp]`
 125   | _ ->
 126       assert false
 127
 128 let emit_reg8 r = emit_subreg reg_low_8_name "BYTE" r
 129 let emit_reg16 r = emit_subreg reg_low_16_name "WORD" r
 130 let emit_reg32 r = emit_subreg reg_low_32_name "DWORD" r
 131
 132 (* Output an addressing mode *)
 133
 134 let emit_signed_int d =
 135   if d > 0 then emit_char '+';
 136   if d <> 0 then emit_int d
 137
 138 let emit_addressing addr r n =
 139   match addr with
 140     Ibased(s, d) ->
 141       add_used_symbol s;
 142       `{emit_symbol s}{emit_signed_int d}`
 143   | Iindexed d ->
 144       `[{emit_reg r.(n)}{emit_signed_int d}]`
 145   | Iindexed2 d ->
 146       `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]`
 147   | Iscaled(2, d) ->
 148       `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]`
 149   | Iscaled(scale, d) ->
 150       `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]`
 151   | Iindexed2scaled(scale, d) ->
 152       `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]`
 153
 154 (* Record live pointers at call points *)
 155
 156 let record_frame_label live dbg =
 157   let lbl = new_label() in
 158   let live_offset = ref [] in
 159   Reg.Set.iter
 160     (function
 161         {typ = Addr; loc = Reg r} ->
 162           live_offset := ((r lsl 1) + 1) :: !live_offset
 163       | {typ = Addr; loc = Stack s} as reg ->
 164           live_offset := slot_offset s (register_class reg) :: !live_offset
 165       | _ -> ())
 166     live;
 167   frame_descriptors :=
 168     { fd_lbl = lbl;
 169       fd_frame_size = frame_size();
 170       fd_live_offset = !live_offset;
 171       fd_debuginfo = dbg } :: !frame_descriptors;
 172   lbl
 173
 174 let record_frame live dbg =
 175   let lbl = record_frame_label live dbg in `{emit_label lbl}:\n`
 176
 177 (* Record calls to the GC -- we've moved them out of the way *)
 178
 179 type gc_call =
 180   { gc_lbl: label;                      (* Entry label *)
 181     gc_return_lbl: label;               (* Where to branch after GC *)
 182     gc_frame: label }                   (* Label of frame descriptor *)
 183
 184 let call_gc_sites = ref ([] : gc_call list)
 185
 186 let emit_call_gc gc =
 187   `{emit_label gc.gc_lbl}:      call    {emit_symbol "caml_call_gc"}\n`;
 188   `{emit_label gc.gc_frame}:    jmp     {emit_label gc.gc_return_lbl}\n`
 189
 190 (* Record calls to caml_ml_array_bound_error.
 191    In -g mode, we maintain one call to caml_ml_array_bound_error
 192    per bound check site.  Without -g, we can share a single call. *)
 193
 194 type bound_error_call =
 195   { bd_lbl: label;                      (* Entry label *)
 196     bd_frame: label }                   (* Label of frame descriptor *)
 197
 198 let bound_error_sites = ref ([] : bound_error_call list)
 199 let bound_error_call = ref 0
 200
 201 let bound_error_label dbg =
 202   if !Clflags.debug then begin
 203     let lbl_bound_error = new_label() in
 204     let lbl_frame = record_frame_label Reg.Set.empty dbg in
 205     bound_error_sites :=
 206      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
 207    lbl_bound_error
 208  end else begin
 209    if !bound_error_call = 0 then bound_error_call := new_label();
 210    !bound_error_call
 211  end
 212
 213 let emit_call_bound_error bd =
 214   `{emit_label bd.bd_lbl}:      call    caml_ml_array_bound_error\n`;
 215   `{emit_label bd.bd_frame}:\n`
 216
 217 let emit_call_bound_errors () =
 218   List.iter emit_call_bound_error !bound_error_sites;
 219   if !bound_error_call > 0 then
 220     `{emit_label !bound_error_call}:    call    caml_ml_array_bound_error\n`
 221
 222 (* Names for instructions *)
 223
 224 let instr_for_intop = function
 225     Iadd -> "add"
 226   | Isub -> "sub"
 227   | Imul -> "imul"
 228   | Iand -> "and"
 229   | Ior -> "or"
 230   | Ixor -> "xor"
 231   | Ilsl -> "sal"
 232   | Ilsr -> "shr"
 233   | Iasr -> "sar"
 234   | _ -> assert false
 235
 236 let instr_for_floatop = function
 237     Iaddf -> "addsd"
 238   | Isubf -> "subsd"
 239   | Imulf -> "mulsd"
 240   | Idivf -> "divsd"
 241   | _ -> assert false
 242
 243 let instr_for_floatarithmem = function
 244     Ifloatadd -> "addsd"
 245   | Ifloatsub -> "subsd"
 246   | Ifloatmul -> "mulsd"
 247   | Ifloatdiv -> "divsd"
 248
 249 let name_for_cond_branch = function
 250     Isigned Ceq -> "e"     | Isigned Cne -> "ne"
 251   | Isigned Cle -> "le"     | Isigned Cgt -> "g"
 252   | Isigned Clt -> "l"     | Isigned Cge -> "ge"
 253   | Iunsigned Ceq -> "e"   | Iunsigned Cne -> "ne"
 254   | Iunsigned Cle -> "be"  | Iunsigned Cgt -> "a"
 255   | Iunsigned Clt -> "b"  | Iunsigned Cge -> "ae"
 256
 257 (* Output an = 0 or <> 0 test. *)
 258
 259 let output_test_zero arg =
 260   match arg.loc with
 261     Reg r -> `  test    {emit_reg arg}, {emit_reg arg}\n`
 262   | _     -> `  cmp     {emit_reg arg}, 0\n`
 263
 264 (* Output a floating-point compare and branch *)
 265
 266 let emit_float_test cmp neg arg lbl =
 267   begin match cmp with
 268   | Ceq | Cne -> `      ucomisd `
 269   | _         -> `      comisd  `
 270   end;
 271   `{emit_reg arg.(0)}, {emit_reg arg.(1)}\n`;
 272   let (branch_opcode, need_jp) =
 273     match (cmp, neg) with
 274       (Ceq, false) -> ("je", true)
 275     | (Ceq, true)  -> ("jne", true)
 276     | (Cne, false) -> ("jne", true)
 277     | (Cne, true)  -> ("je", true)
 278     | (Clt, false) -> ("jb", true)
 279     | (Clt, true)  -> ("jae", true)
 280     | (Cle, false) -> ("jbe", true)
 281     | (Cle, true)  -> ("ja", true)
 282     | (Cgt, false) -> ("ja", false)
 283     | (Cgt, true)  -> ("jbe", false)
 284     | (Cge, false) -> ("jae", true)
 285     | (Cge, true)  -> ("jb", false) in
 286   let branch_if_not_comparable =
 287     if cmp = Cne then not neg else neg in
 288   if need_jp then
 289     if branch_if_not_comparable then begin
 290       ` jp      {emit_label lbl}\n`;
 291       ` {emit_string branch_opcode}     {emit_label lbl}\n`
 292     end else begin
 293       let next = new_label() in
 294       ` jp      {emit_label next}\n`;
 295       ` {emit_string branch_opcode}     {emit_label lbl}\n`;
 296       `{emit_label next}:\n`
 297     end
 298   else begin
 299     `   {emit_string branch_opcode}     {emit_label lbl}\n`
 300   end
 301
 302 (* Deallocate the stack frame before a return or tail call *)
 303
 304 let output_epilogue () =
 305   if frame_required() then begin
 306     let n = frame_size() - 8 in
 307     `   add     rsp, {emit_int n}\n`
 308   end
 309
 310 (* Output the assembly code for an instruction *)
 311
 312 (* Name of current function *)
 313 let function_name = ref ""
 314 (* Entry point for tail recursive calls *)
 315 let tailrec_entry_point = ref 0
 316
 317 let float_constants = ref ([] : (int * string) list)
 318
 319 let emit_instr fallthrough i =
 320     match i.desc with
 321       Lend -> ()
 322     | Lop(Imove | Ispill | Ireload) ->
 323         let src = i.arg.(0) and dst = i.res.(0) in
 324         if src.loc <> dst.loc then begin
 325           if src.typ = Float then
 326             `   movsd   {emit_reg dst}, {emit_reg src}\n`
 327           else
 328             `   mov     {emit_reg dst}, {emit_reg src}\n`
 329         end
 330     | Lop(Iconst_int n) ->
 331         if n = 0n then begin
 332           match i.res.(0).loc with
 333             Reg n -> `  xor     {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 334           | _     -> `  mov     {emit_reg i.res.(0)}, 0\n`
 335         end else if n >= -0x80000000n && n <= 0x7FFFFFFFn then
 336           `     mov     {emit_reg i.res.(0)}, {emit_nativeint n}\n`
 337         else if n >= 0x80000000n && n <= 0xFFFFFFFFn  then
 338           (* work around bug in ml64 *)
 339           `     mov     {emit_reg32 i.res.(0)}, {emit_nativeint n}\n`
 340         else
 341           (* force ml64 to use mov reg, imm64 instruction *)
 342           `     mov     {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n`
 343     | Lop(Iconst_float s) ->
 344         begin match Int64.bits_of_float (float_of_string s) with
 345         | 0x0000_0000_0000_0000L ->       (* +0.0 *)
 346           `     xorpd   {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 347         | _ ->
 348           let lbl = new_label() in
 349           float_constants := (lbl, s) :: !float_constants;
 350           `     movlpd  {emit_reg i.res.(0)}, {emit_label lbl}\n`
 351         end
 352     | Lop(Iconst_symbol s) ->
 353         add_used_symbol s;
 354         if !pic_code then
 355           `     lea     {emit_reg i.res.(0)}, {emit_symbol s}\n`
 356         else
 357           `     mov     {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n`
 358     | Lop(Icall_ind) ->
 359         `       call    {emit_reg i.arg.(0)}\n`;
 360         record_frame i.live i.dbg
 361     | Lop(Icall_imm s) ->
 362         add_used_symbol s;
 363         `       call    {emit_symbol s}\n`;
 364         record_frame i.live i.dbg
 365     | Lop(Itailcall_ind) ->
 366         output_epilogue();
 367         `       jmp     {emit_reg i.arg.(0)}\n`
 368     | Lop(Itailcall_imm s) ->
 369         if s = !function_name then
 370           `     jmp     {emit_label !tailrec_entry_point}\n`
 371         else begin
 372           add_used_symbol s;
 373           output_epilogue();
 374           `     jmp     {emit_symbol s}\n`
 375         end
 376     | Lop(Iextcall(s, alloc)) ->
 377         add_used_symbol s;
 378         if alloc then begin
 379           `     lea     rax, {emit_symbol s}\n`;
 380           `     call    {emit_symbol "caml_c_call"}\n`;
 381           record_frame i.live i.dbg
 382         end else begin
 383           `     call    {emit_symbol s}\n`
 384         end
 385     | Lop(Istackoffset n) ->
 386         if n < 0
 387         then `  add     rsp, {emit_int(-n)}\n`
 388         else `  sub     rsp, {emit_int(n)}\n`;
 389         stack_offset := !stack_offset + n
 390     | Lop(Iload(chunk, addr)) ->
 391         let dest = i.res.(0) in
 392         begin match chunk with
 393           | Word ->
 394               ` mov     {emit_reg dest}, QWORD PTR {emit_addressing addr i.arg 0}\n`
 395           | Byte_unsigned ->
 396               ` movzx   {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n`
 397           | Byte_signed ->
 398               ` movsx   {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n`
 399           | Sixteen_unsigned ->
 400               ` movzx   {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n`
 401           | Sixteen_signed ->
 402               ` movsx   {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n`
 403           | Thirtytwo_unsigned ->
 404               (* load to low 32 bits sets high 32 bits to 0 *)
 405               ` mov     {emit_reg32 dest}, DWORD PTR {emit_addressing addr i.arg 0}\n`
 406           | Thirtytwo_signed ->
 407               ` movsxd  {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n`
 408           | Single ->
 409             `   cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n`
 410           | Double | Double_u ->
 411             `   movlpd  {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
 412         end
 413     | Lop(Istore(chunk, addr)) ->
 414         begin match chunk with
 415           | Word ->
 416             `   mov     QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
 417           | Byte_unsigned | Byte_signed ->
 418             `   mov     BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n`
 419           | Sixteen_unsigned | Sixteen_signed ->
 420             `   mov     WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n`
 421           | Thirtytwo_signed | Thirtytwo_unsigned ->
 422             `   mov     DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg32 i.arg.(0)}\n`
 423           | Single ->
 424             `   cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`;
 425             `   movss   REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n`
 426           | Double | Double_u ->
 427             `   movlpd  REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
 428         end
 429     | Lop(Ialloc n) ->
 430         if !fastcode_flag then begin
 431           let lbl_redo = new_label() in
 432           `{emit_label lbl_redo}:       sub     r15, {emit_int n}\n`;
 433           `     cmp     r15, {emit_symbol "caml_young_limit"}\n`;
 434           let lbl_call_gc = new_label() in
 435           let lbl_frame = record_frame_label i.live Debuginfo.none in
 436           `     jb      {emit_label lbl_call_gc}\n`;
 437           `     lea     {emit_reg i.res.(0)}, [r15+8]\n`;
 438           call_gc_sites :=
 439             { gc_lbl = lbl_call_gc;
 440               gc_return_lbl = lbl_redo;
 441               gc_frame = lbl_frame } :: !call_gc_sites
 442         end else begin
 443           begin match n with
 444             16  -> `    call    {emit_symbol "caml_alloc1"}\n`
 445           | 24 -> `     call    {emit_symbol "caml_alloc2"}\n`
 446           | 32 -> `     call    {emit_symbol "caml_alloc3"}\n`
 447           | _  -> `     mov     rax, {emit_int n}\n`;
 448                   `     call    {emit_symbol "caml_allocN"}\n`
 449           end;
 450           `{record_frame i.live Debuginfo.none} lea     {emit_reg i.res.(0)}, [r15+8]\n`
 451         end
 452     | Lop(Iintop(Icomp cmp)) ->
 453         `       cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 454         let b = name_for_cond_branch cmp in
 455         `       set{emit_string b}      al\n`;
 456         `       movzx   {emit_reg i.res.(0)}, al\n`
 457     | Lop(Iintop_imm(Icomp cmp, n)) ->
 458         `       cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
 459         let b = name_for_cond_branch cmp in
 460         `       set{emit_string b}      al\n`;
 461         `       movzx   {emit_reg i.res.(0)}, al\n`
 462     | Lop(Iintop Icheckbound) ->
 463         let lbl = bound_error_label i.dbg in
 464         `       cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 465         `       jbe     {emit_label lbl}\n`
 466     | Lop(Iintop_imm(Icheckbound, n)) ->
 467         let lbl = bound_error_label i.dbg in
 468         `       cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
 469         `       jbe     {emit_label lbl}\n`
 470     | Lop(Iintop(Idiv | Imod)) ->
 471         `       cqo\n`;
 472         `       idiv    {emit_reg i.arg.(1)}\n`
 473     | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
 474         (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *)
 475         `       {emit_string(instr_for_intop op)}       {emit_reg i.res.(0)}, cl\n`
 476     | Lop(Iintop op) ->
 477         (* We have i.arg.(0) = i.res.(0) *)
 478         `       {emit_string(instr_for_intop op)}       {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`
 479     | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc ->
 480         `       lea     {emit_reg i.res.(0)}, {emit_int n}[{emit_reg i.arg.(0)}]\n`
 481     | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
 482         `       inc     {emit_reg i.res.(0)}\n`
 483     | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
 484         `       dec     {emit_reg i.res.(0)}\n`
 485     | Lop(Iintop_imm(Idiv, n)) ->
 486         (* Note: i.arg.(0) = i.res.(0) = rdx  (cf. selection.ml) *)
 487         let l = Misc.log2 n in
 488         `       mov     rax, {emit_reg i.arg.(0)}\n`;
 489         `       add     {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`;
 490         `       test    rax, rax\n`;
 491         `       cmovns  {emit_reg i.arg.(0)}, rax\n`;
 492         `       sar     {emit_reg i.res.(0)}, {emit_int l}\n`
 493     | Lop(Iintop_imm(Imod, n)) ->
 494         (* Note: i.arg.(0) = i.res.(0) = rdx  (cf. selection.ml) *)
 495         `       mov     rax, {emit_reg i.arg.(0)}\n`;
 496         `       test    rax, rax\n`;
 497         `       lea     rax, {emit_int(n-1)}[rax]\n`;
 498         `       cmovns  rax, {emit_reg i.arg.(0)}\n`;
 499         `       and     rax, {emit_int (-n)}\n`;
 500         `       sub     {emit_reg i.res.(0)}, rax\n`
 501     | Lop(Iintop_imm(op, n)) ->
 502         (* We have i.arg.(0) = i.res.(0) *)
 503         `       {emit_string(instr_for_intop op)}       {emit_reg i.res.(0)}, {emit_int n}\n`
 504     | Lop(Inegf) ->
 505         `       xorpd   {emit_reg i.res.(0)}, {emit_symbol "caml_negf_mask"}\n`
 506     | Lop(Iabsf) ->
 507         `       andpd   {emit_reg i.res.(0)}, {emit_symbol "caml_absf_mask"}\n`
 508     | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
 509         `       {emit_string(instr_for_floatop floatop)}        {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`
 510     | Lop(Ifloatofint) ->
 511         `       cvtsi2sd        {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
 512     | Lop(Iintoffloat) ->
 513         `       cvttsd2si       {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
 514     | Lop(Ispecific(Ilea addr)) ->
 515         `       lea     {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
 516     | Lop(Ispecific(Istore_int(n, addr))) ->
 517         `       mov     QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n`
 518     | Lop(Ispecific(Istore_symbol(s, addr))) ->
 519         assert (not !pic_code);
 520         add_used_symbol s;
 521         `       mov     QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n`
 522     | Lop(Ispecific(Ioffset_loc(n, addr))) ->
 523         `       add     QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n`
 524     | Lop(Ispecific(Ifloatarithmem(op, addr))) ->
 525         `       {emit_string(instr_for_floatarithmem op)}       {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n`
 526     | Lreloadretaddr ->
 527         ()
 528     | Lreturn ->
 529         output_epilogue();
 530         `       ret\n`
 531     | Llabel lbl ->
 532         `{emit_Llabel fallthrough lbl}:\n`
 533     | Lbranch lbl ->
 534         `       jmp     {emit_label lbl}\n`
 535     | Lcondbranch(tst, lbl) ->
 536         begin match tst with
 537           Itruetest ->
 538             output_test_zero i.arg.(0);
 539             `   jne     {emit_label lbl}\n`
 540         | Ifalsetest ->
 541             output_test_zero i.arg.(0);
 542             `   je      {emit_label lbl}\n`
 543         | Iinttest cmp ->
 544             `   cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 545             let b = name_for_cond_branch cmp in
 546             `   j{emit_string b}        {emit_label lbl}\n`
 547         | Iinttest_imm((Isigned Ceq | Isigned Cne |
 548                         Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
 549             output_test_zero i.arg.(0);
 550             let b = name_for_cond_branch cmp in
 551             `   j{emit_string b}        {emit_label lbl}\n`
 552         | Iinttest_imm(cmp, n) ->
 553             `   cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
 554             let b = name_for_cond_branch cmp in
 555             `   j{emit_string b}        {emit_label lbl}\n`
 556         | Ifloattest(cmp, neg) ->
 557             emit_float_test cmp neg i.arg lbl
 558         | Ioddtest ->
 559             `   test    {emit_reg8 i.arg.(0)}, 1\n`;
 560             `   jne     {emit_label lbl}\n`
 561         | Ieventest ->
 562             `   test    {emit_reg8 i.arg.(0)}, 1\n`;
 563             `   je      {emit_label lbl}\n`
 564         end
 565     | Lcondbranch3(lbl0, lbl1, lbl2) ->
 566             `   cmp     {emit_reg i.arg.(0)}, 1\n`;
 567             begin match lbl0 with
 568               None -> ()
 569             | Some lbl -> `     jb      {emit_label lbl}\n`
 570             end;
 571             begin match lbl1 with
 572               None -> ()
 573             | Some lbl -> `     je      {emit_label lbl}\n`
 574             end;
 575             begin match lbl2 with
 576               None -> ()
 577             | Some lbl -> `     jg      {emit_label lbl}\n`
 578             end
 579     | Lswitch jumptbl ->
 580         let lbl = new_label() in
 581         if !pic_code then begin
 582           `     lea     r11, {emit_label lbl}\n`;
 583           `     jmp     QWORD PTR [r11+{emit_reg i.arg.(0)}*8]\n`
 584         end else begin
 585           `     jmp     QWORD PTR [{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n`
 586         end;
 587         `       .DATA\n`;
 588         emit_align 8;
 589         `{emit_label lbl}       LABEL QWORD\n`;
 590         for i = 0 to Array.length jumptbl - 1 do
 591           `     QWORD   {emit_label jumptbl.(i)}\n`
 592         done;
 593         `       .CODE\n`
 594     | Lsetuptrap lbl ->
 595         `       call    {emit_label lbl}\n`
 596     | Lpushtrap ->
 597         `       push    r14\n`;
 598         `       mov     r14, rsp\n`;
 599         stack_offset := !stack_offset + 16
 600     | Lpoptrap ->
 601         `       pop     r14\n`;
 602         `       add     rsp, 8\n`;
 603         stack_offset := !stack_offset - 16
 604     | Lraise ->
 605         if !Clflags.debug then begin
 606           `     call    caml_raise_exn\n`;
 607           record_frame Reg.Set.empty i.dbg
 608         end else begin
 609           `     mov     rsp, r14\n`;
 610           `     pop     r14\n`;
 611           `     ret\n`
 612         end
 613
 614 let rec emit_all fallthrough i =
 615   match i.desc with
 616   |  Lend -> ()
 617   | _ ->
 618       emit_instr fallthrough i;
 619       emit_all (Linearize.has_fallthrough i.desc) i.next
 620
 621 (* Emission of the floating-point constants *)
 622
 623 let emit_float s =
 624   (* MASM doesn't like floating-point constants such as 2e9.
 625      Turn them into 2.0e9. *)
 626   let pos_e = ref (-1) and pos_dot = ref (-1) in
 627   for i = 0 to String.length s - 1 do
 628     match s.[i] with
 629       'e'|'E' -> pos_e := i
 630     | '.'     -> pos_dot := i
 631     | _       -> ()
 632   done;
 633   if !pos_dot < 0 && !pos_e >= 0 then begin
 634     emit_string (String.sub s 0 !pos_e);
 635     emit_string ".0";
 636     emit_string (String.sub s !pos_e (String.length s - !pos_e))
 637   end else
 638     emit_string s
 639
 640 let emit_float_constant (lbl, cst) =
 641   `{emit_label lbl}     REAL8   {emit_float cst}\n`
 642
 643 (* Emission of a function declaration *)
 644
 645 let fundecl fundecl =
 646   function_name := fundecl.fun_name;
 647   fastcode_flag := fundecl.fun_fast;
 648   tailrec_entry_point := new_label();
 649   stack_offset := 0;
 650   float_constants := [];
 651   call_gc_sites := [];
 652   bound_error_sites := [];
 653   bound_error_call := 0;
 654   `     .CODE\n`;
 655   emit_align 16;
 656   add_def_symbol fundecl.fun_name;
 657   `     PUBLIC  {emit_symbol fundecl.fun_name}\n`;
 658   `{emit_symbol fundecl.fun_name}:\n`;
 659   if frame_required() then begin
 660     let n = frame_size() - 8 in
 661     `   sub     rsp, {emit_int n}\n`
 662   end;
 663   `{emit_label !tailrec_entry_point}:\n`;
 664   emit_all true fundecl.fun_body;
 665   List.iter emit_call_gc !call_gc_sites;
 666   emit_call_bound_errors();
 667   if !float_constants <> [] then begin
 668     `   .DATA\n`;
 669     List.iter emit_float_constant !float_constants
 670   end
 671
 672 (* Emission of data *)
 673
 674 let emit_item = function
 675     Cglobal_symbol s ->
 676       ` PUBLIC  {emit_symbol s}\n`;
 677   | Cdefine_symbol s ->
 678       add_def_symbol s;
 679       `{emit_symbol s} LABEL QWORD\n`
 680   | Cdefine_label lbl ->
 681       `{emit_label (100000 + lbl)} LABEL QWORD\n`
 682   | Cint8 n ->
 683       ` BYTE    {emit_int n}\n`
 684   | Cint16 n ->
 685       ` WORD    {emit_int n}\n`
 686   | Cint32 n ->
 687       ` DWORD   {emit_nativeint n}\n`
 688   | Cint n ->
 689       ` QWORD   {emit_nativeint n}\n`
 690   | Csingle f ->
 691       ` REAL4   {emit_float f}\n`
 692   | Cdouble f ->
 693       ` REAL8   {emit_float f}\n`
 694   | Csymbol_address s ->
 695       add_used_symbol s;
 696       ` QWORD   {emit_symbol s}\n`
 697   | Clabel_address lbl ->
 698       ` QWORD   {emit_label (100000 + lbl)}\n`
 699   | Cstring s ->
 700       emit_bytes_directive "    BYTE    " s
 701   | Cskip n ->
 702       if n > 0 then `   BYTE    {emit_int n} DUP (?)\n`
 703   | Calign n ->
 704       emit_align n
 705
 706 let data l =
 707   `     .DATA\n`;
 708   List.iter emit_item l
 709
 710 (* Beginning / end of an assembly file *)
 711
 712 let begin_assembly() =
 713   `     EXTRN caml_young_ptr: QWORD\n`;
 714   `     EXTRN caml_young_limit: QWORD\n`;
 715   `     EXTRN caml_exception_pointer: QWORD\n`;
 716   `     EXTRN caml_absf_mask: QWORD\n`;
 717   `     EXTRN caml_negf_mask: QWORD\n`;
 718   `     EXTRN caml_call_gc: NEAR\n`;
 719   `     EXTRN caml_c_call: NEAR\n`;
 720   `     EXTRN caml_allocN: NEAR\n`;
 721   `     EXTRN caml_alloc1: NEAR\n`;
 722   `     EXTRN caml_alloc2: NEAR\n`;
 723   `     EXTRN caml_alloc3: NEAR\n`;
 724   `     EXTRN caml_ml_array_bound_error: NEAR\n`;
 725   `     EXTRN caml_raise_exn: NEAR\n`;
 726   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
 727   add_def_symbol lbl_begin;
 728   `     .DATA\n`;
 729   `     PUBLIC  {emit_symbol lbl_begin}\n`;
 730   `{emit_symbol lbl_begin} LABEL QWORD\n`;
 731   let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
 732   add_def_symbol lbl_begin;
 733   `     .CODE\n`;
 734   `     PUBLIC  {emit_symbol lbl_begin}\n`;
 735   `{emit_symbol lbl_begin} LABEL QWORD\n`
 736
 737 let end_assembly() =
 738   let lbl_end = Compilenv.make_symbol (Some "code_end") in
 739   add_def_symbol lbl_end;
 740   `     .CODE\n`;
 741   `     PUBLIC  {emit_symbol lbl_end}\n`;
 742   `{emit_symbol lbl_end} LABEL QWORD\n`;
 743   `     .DATA\n`;
 744   let lbl_end = Compilenv.make_symbol (Some "data_end") in
 745   add_def_symbol lbl_end;
 746   `     PUBLIC  {emit_symbol lbl_end}\n`;
 747   `{emit_symbol lbl_end} LABEL QWORD\n`;
 748   `     QWORD   0\n`;
 749   let lbl = Compilenv.make_symbol (Some "frametable") in
 750   add_def_symbol lbl;
 751   `     PUBLIC  {emit_symbol lbl}\n`;
 752   `{emit_symbol lbl} LABEL QWORD\n`;
 753   emit_frames
 754     { efa_label = (fun l -> `   QWORD   {emit_label l}\n`);
 755       efa_16 = (fun n -> `      WORD    {emit_int n}\n`);
 756       efa_32 = (fun n -> `      DWORD   {emit_int32 n}\n`);
 757       efa_word = (fun n -> `    QWORD   {emit_int n}\n`);
 758       efa_align = emit_align;
 759       efa_label_rel = (fun lbl ofs ->
 760                            `    DWORD   {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`);
 761       efa_def_label = (fun l -> `{emit_label l} LABEL   QWORD\n`);
 762       efa_string = (fun s -> emit_bytes_directive  "    BYTE    " (s ^ "\000")) };
 763   `\n;External functions\n\n`;
 764   StringSet.iter
 765     (fun s ->
 766       if not (StringSet.mem s !symbols_defined) then
 767         `       EXTRN   {emit_symbol s}: NEAR\n`)
 768     !symbols_used;
 769   symbols_used := StringSet.empty;
 770   symbols_defined := StringSet.empty;
 771   `END\n`