ocaml/asmcomp/amd64/emit.mlp

# 2 "asmcomp/amd64/emit.mlp"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* Emission of Intel x86_64 assembly code *)

open Cmm
open Arch
open Proc
open Reg
open Mach
open Linearize
open Emitaux
open Intel_proc
open Intel_gas.DSL64

module I = Intel_gas.INS64

(* Override proc.ml *)

let int_reg_name =
  [| RAX; RBX; RDI; RSI; RDX; RCX; R8; R9;
     R12; R13; R10; R11; RBP; |]

let float_reg_name = Array.init 16 (fun i -> XMM i)

let register_name r =
  if r < 100 then _r (int_reg_name.(r))
  else Regf (float_reg_name.(r - 100))

(* CFI directives *)

let is_cfi_enabled () =
  Config.asm_cfi_supported

let cfi_startproc () =
  if is_cfi_enabled () then
    _cfi_startproc ()

let cfi_endproc () =
  if is_cfi_enabled () then
    _cfi_endproc ()

let cfi_adjust_cfa_offset n =
  if is_cfi_enabled () then
    _cfi_adjust_cfa_offset n

let emit_debug_info dbg =
  if system <> S_win64 then
    emit_debug_info_gen dbg _file _loc

let fp = Config.with_frame_pointers

(* Tradeoff between code size and code speed *)

let fastcode_flag = ref true

let stack_offset = ref 0

(* Layout of the stack frame *)

let frame_required () =
  fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0

let frame_size () =                     (* includes return address *)
  if frame_required() then begin
    let sz =
      (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8
      + (if fp then 8 else 0) )
    in Misc.align sz 16
  end else
    !stack_offset + 8

let slot_offset loc cl =
  match loc with
    Incoming n -> frame_size() + n
  | Local n ->
      if cl = 0
      then !stack_offset + n * 8
      else !stack_offset + (num_stack_slots.(0) + n) * 8
  | Outgoing n -> n

(* Symbols *)

let symbol_prefix = if system = S_macosx then "_" else ""

let emit_symbol s =
  string_of_symbol symbol_prefix s

(* Record symbols used and defined - at the end generate extern for those
   used but not defined *)

let symbols_defined = ref StringSet.empty
let symbols_used = ref StringSet.empty

let add_def_symbol s =
  symbols_defined := StringSet.add s !symbols_defined

let add_used_symbol s =
  symbols_used := StringSet.add s !symbols_used

let emit_call s =
  I.call (
    if !Clflags.dlcode && (match system with
           S_macosx | S_mingw64 | S_cygwin | S_win64 -> false
         | _ -> true)
    then rel_ (plt_ (emit_symbol s))
    else _l (emit_symbol s)
  )

let emit_jump s =
  I.jmp (
    if !Clflags.dlcode && (match system with
           S_macosx | S_mingw64 |S_cygwin | S_win64 -> false
         | _ -> true)
    then rel_ (plt_ (emit_symbol s))
    else _l (emit_symbol s)
  )

let load_symbol_addr s arg =
  if system = S_win64 then
    if !pic_code then
          I.leaq ( at_rip NO (abs_ (emit_symbol s)) 0 , arg )
        else
          I.movq ( _offset (abs_ (emit_symbol s)), arg )
  else
    let addr =
      if !Clflags.dlcode && (match system with
             S_mingw64 | S_cygwin | S_win64 -> false
           | _ -> true)
      then at_rip NO (gotpcrel_ (emit_symbol s)) 0
      else if !pic_code
      then at_rip NO (abs_ (emit_symbol s)) 0
      else _offset (abs_ (emit_symbol s))
    in
    I.movq (addr,  arg)

(* Output a label *)

let emit_label lbl =
  if system = S_win64 then
    Printf.sprintf "L%d" lbl
  else
    Printf.sprintf ".L%d" lbl

let emit_data_label lbl =
  if system = S_win64 then
    Printf.sprintf "Ld%d" lbl
  else
    Printf.sprintf ".Ld%d" lbl

(* Output a .align directive. *)

let emit_align n =
  let n = if system = S_macosx then Misc.log2 n else n in
(* we must remember the segment, because text segments are filled with nop *)
  _align n (* TODO *)

let emit_Llabel fallthrough lbl =
  if not fallthrough && !fastcode_flag then emit_align 4;
  emit_label lbl

(* Output a pseudo-register *)

let emit_reg = function
    { loc = Reg.Reg r } -> register_name r
  | { loc = Stack s; typ = Float } as r ->
    let ofs = slot_offset s (register_class r) in
    _mem_ptr REAL8 ofs RSP
  | { loc = Stack s } as r ->
    let ofs = slot_offset s (register_class r) in
    _mem_ptr QWORD ofs RSP
  | { loc = Unknown } ->
    assert false

  (* Output a reference to the lower 8, 16 or 32 bits of a register *)

let reg_low_8_name =  Array.map (fun r -> Reg8 r)
  [| AL; BL; DIL; SIL; DL; CL; R8B; R9B;
     R12B; R13B; R10B; R11B; BPL; |]

let reg_low_16_name = Array.map (fun r -> Reg16 r)
  [| AX; BX; DI; SI; DX; CX; R8W; R9W;
     R12W; R13W; R10W; R11W; BP; |]

let reg_low_32_name = Array.map (fun r -> Reg32 r)
  [| _eax; _ebx; _edi; _esi; _edx; _ecx; _r8d; _r9d;
     _r12d; _r13d; _r10d; _r11d; _ebp; |]

let emit_subreg tbl pref r =
  match r.loc with
    Reg.Reg r when r < 13 ->
    tbl.(r)
  | Stack s ->
    let ofs = slot_offset s (register_class r) in
    _mem_ptr pref ofs RSP
  | _ ->
    assert false

let emit_reg8 r = emit_subreg reg_low_8_name BYTE r
let emit_reg16 r = emit_subreg reg_low_16_name WORD r
let emit_reg32 r = emit_subreg reg_low_32_name DWORD r
let emit_reg64 = function
    | { loc = Reg.Reg r } -> int_reg_name.(r)
    | _ -> assert false

(* Output an addressing mode *)

let emit_addressing addr pref r n =
  match addr with
(*  | Ibased _ when !Clflags.dlcode -> assert false ONLY on Unix *)
  | Ibased(s, d) ->
    add_used_symbol s;
    at_rip pref (abs_ s) d
  | Iindexed d ->
    _mem_ptr pref d (emit_reg64 r.(n))
  | Iindexed2 d ->
    Mem (pref, M64(Some (emit_reg64 r.(n+1), 1, Some (emit_reg64 r.(n))),
        (None, Int64.of_int d)))
  | Iscaled(2, d) ->
    Mem (pref, M64(Some (emit_reg64 r.(n), 1, Some (emit_reg64 r.(n))),
        (None, Int64.of_int d)))
  | Iscaled(scale, d) ->
    Mem (pref, M64(Some (emit_reg64 r.(n), scale, None),
        (None, Int64.of_int d)))
  | Iindexed2scaled(scale, d) ->
    Mem (pref, M64(Some (emit_reg64 r.(n+1), scale, Some (emit_reg64 r.(n))),
        (None, Int64.of_int d)))

(* Record live pointers at call points -- see Emitaux *)

let record_frame_label live dbg =
  let lbl = new_label() in
  let live_offset = ref [] in
  Reg.Set.iter
    (function
        {typ = Addr; loc = Reg r} ->
          live_offset := ((r lsl 1) + 1) :: !live_offset
      | {typ = Addr; loc = Stack s} as reg ->
          live_offset := slot_offset s (register_class reg) :: !live_offset
      | _ -> ())
    live;
  frame_descriptors :=
    { fd_lbl = lbl;
      fd_frame_size = frame_size();
      fd_live_offset = !live_offset;
      fd_debuginfo = dbg } :: !frame_descriptors;
  lbl

let record_frame live dbg =
  let lbl = record_frame_label live dbg in
  _llabel (emit_label lbl)

(* Record calls to the GC -- we've moved them out of the way *)

type gc_call =
  { gc_lbl: label;                      (* Entry label *)
    gc_return_lbl: label;               (* Where to branch after GC *)
    gc_frame: label }                   (* Label of frame descriptor *)

let call_gc_sites = ref ([] : gc_call list)

let emit_call_gc gc =
  _llabel (emit_label gc.gc_lbl);
  emit_call "caml_call_gc";
  _llabel (emit_label gc.gc_frame);
  I.jmp ( _l (emit_label gc.gc_return_lbl)  )

(* Record calls to caml_ml_array_bound_error.
   In -g mode, we maintain one call to caml_ml_array_bound_error
   per bound check site.  Without -g, we can share a single call. *)

type bound_error_call =
  { bd_lbl: label;                      (* Entry label *)
    bd_frame: label }                   (* Label of frame descriptor *)

let bound_error_sites = ref ([] : bound_error_call list)
let bound_error_call = ref 0

let bound_error_label dbg =
  if !Clflags.debug then begin
    let lbl_bound_error = new_label() in
    let lbl_frame = record_frame_label Reg.Set.empty dbg in
    bound_error_sites :=
     { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
   lbl_bound_error
 end else begin
   if !bound_error_call = 0 then bound_error_call := new_label();
   !bound_error_call
 end

let emit_call_bound_error bd =
  _llabel (emit_label bd.bd_lbl);
  emit_call "caml_ml_array_bound_error";
  _llabel (emit_label bd.bd_frame)

let emit_call_bound_errors () =
  List.iter emit_call_bound_error !bound_error_sites;
  if !bound_error_call > 0 then begin
    _llabel (emit_label !bound_error_call);
    emit_call "caml_ml_array_bound_error"
  end

(* Names for instructions *)

let instr_for_intop = function
    Iadd -> I.addq
  | Isub -> I.subq
  | Imul -> (fun (arg1, arg2) -> I.imulq (arg1, Some arg2))
  | Iand -> I.andq
  | Ior -> I.orq
  | Ixor -> I.xorq
  | Ilsl -> I.salq
  | Ilsr -> I.shrq
  | Iasr -> I.sarq
  | _ -> assert false

let instr_for_floatop = function
    Iaddf -> I.addsd
  | Isubf -> I.subsd
  | Imulf -> I.mulsd
  | Idivf -> I.divsd
  | _ -> assert false

let instr_for_floatarithmem = function
    Ifloatadd -> I.addsd
  | Ifloatsub -> I.subsd
  | Ifloatmul -> I.mulsd
  | Ifloatdiv -> I.divsd

let name_for_cond_branch = function
    Isigned Ceq -> E     | Isigned Cne -> NE
  | Isigned Cle -> LE     | Isigned Cgt -> G
  | Isigned Clt -> L     | Isigned Cge -> GE
  | Iunsigned Ceq -> E   | Iunsigned Cne -> NE
  | Iunsigned Cle -> BE  | Iunsigned Cgt -> A
  | Iunsigned Clt -> B  | Iunsigned Cge -> AE

(* Output an = 0 or <> 0 test. *)

let output_test_zero arg =
  match arg.loc with
    Reg.Reg r -> I.testq  ( emit_reg arg, emit_reg arg )
  | _  -> I.cmpq  ( _int 0, emit_reg arg )

(* Output a floating-point compare and branch *)

let emit_float_test cmp neg arg lbl =
  (* Effect of comisd on flags and conditional branches:
                     ZF PF CF  cond. branches taken
        unordered     1  1  1  je, jb, jbe, jp
        >             0  0  0  jne, jae, ja
        <             0  0  1  jne, jbe, jb
        =             1  0  0  je, jae, jbe.
     If FP traps are on (they are off by default),
     comisd traps on QNaN and SNaN but ucomisd traps on SNaN only.
  *)
  match (cmp, neg) with
  | (Ceq, false) | (Cne, true) ->
    let next = new_label() in
    I.ucomisd ( emit_reg arg.(1) , emit_reg arg.(0) );
    I.jp ( _l (emit_label next)  ); (* skip if unordered *)
    I.je ( _l (emit_label lbl)  ); (* branch taken if x=y *)
    _llabel (emit_label next)
  | (Cne, false) | (Ceq, true) ->
    I.ucomisd ( emit_reg arg.(1), emit_reg arg.(0);  );
    I.jp ( _l (emit_label lbl)  );(* branch taken if unordered *)
    I.jne ( _l (emit_label lbl)  ) (* branch taken if x<y or x>y *)
  | (Clt, _) ->
    I.comisd ( emit_reg arg.(0), emit_reg arg.(1);  );
    if not neg then
      I.ja ( _l (emit_label lbl)  )  (* branch taken if y>x i.e. x<y *)
    else
      I.jbe ( _l (emit_label lbl)  ) (* taken if unordered or y<=x i.e. !(x<y) *)
  | (Cle, _) ->
    I.comisd ( emit_reg arg.(0), emit_reg arg.(1)  );  (* swap compare *)
    if not neg then
      I.jae ( _l (emit_label lbl)  )  (* branch taken if y>=x i.e. x<=y *)
    else
      I.jb ( _l (emit_label lbl)  ) (* taken if unordered or y<x i.e. !(x<=y) *)
  | (Cgt, _) ->
    I.comisd ( emit_reg arg.(1), emit_reg arg.(0);  );
    if not neg then
      I.ja ( _l (emit_label lbl)  )     (* branch taken if x>y *)
    else
      I.jbe ( _l (emit_label lbl)  ) (* taken if unordered or x<=y i.e. !(x>y) *)
  | (Cge, _) ->
    I.comisd (  emit_reg arg.(1), emit_reg arg.(0);  );  (* swap compare *)
    if not neg then
      I.jae ( _l (emit_label lbl)  )    (* branch taken if x>=y *)
    else
      I.jb ( _l (emit_label lbl)  ) (* taken if unordered or x<y i.e. !(x>=y) *)

(* Deallocate the stack frame before a return or tail call *)

let output_epilogue f =
  if frame_required() then begin
    let n = frame_size() - 8 - (if fp then 8 else 0) in
    I.addq ( _int n, _r RSP;  );
    cfi_adjust_cfa_offset (-n);
    if fp then begin
       I.popq ( _r RBP  )
    end;
    f ();
    (* reset CFA back cause function body may continue *)
    cfi_adjust_cfa_offset n
  end
  else
    f ()

(* Floating-point constants *)

let float_constants = ref ([] : (int64 * int) list)

let add_float_constant cst =
  let repr = Int64.bits_of_float cst in
  try
    List.assoc repr !float_constants
  with
    Not_found ->
      let lbl = new_label() in
      float_constants := (repr, lbl) :: !float_constants;
      lbl

let emit_float_constant f lbl =
  _label (emit_label lbl);
  _qword (Const (B64, f))

let emit_global_label lbl =
  let lbl = emit_symbol lbl in
  _global lbl;
  _label lbl


(* Output the assembly code for an instruction *)

(* Name of current function *)
let function_name = ref ""
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0

(* Emit an instruction *)
let emit_instr fallthrough i =
  emit_debug_info i.dbg;
  match i.desc with
    Lend -> ()
  | Lop(Imove | Ispill | Ireload) ->
    let src = i.arg.(0) and dst = i.res.(0) in
    if src.loc <> dst.loc then
      begin match src.typ, src.loc, dst.loc with
          Float, Reg.Reg _, Reg.Reg _ ->
          I.movapd ( emit_reg src, emit_reg dst;   )
        | Float, _, _ ->
          I.movsd ( emit_reg src, emit_reg dst;   )
        | _ ->
          I.movq ( emit_reg src, emit_reg dst;   )
      end
  | Lop(Iconst_int n | Iconst_blockheader n) ->
    if n = 0n then begin
      match i.res.(0).loc with
        Reg n -> I.xorq ( emit_reg i.res.(0), emit_reg i.res.(0)  )
      | _     -> I.movq ( _int 0, emit_reg i.res.(0);  )
    end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then
      I.movq ( emit_nat n, emit_reg i.res.(0);   )
    else
    if system = S_win64 && n >= 0x80000000n && n <= 0xFFFFFFFFn  then
      (* work around bug in ml64 *)
      I.movl ( emit_nat n, emit_reg32 i.res.(0);   )
    else
      I.movabsq ( emit_nat n, emit_reg i.res.(0);   )
  | Lop(Iconst_float f) ->
    begin match Int64.bits_of_float f with
      | 0x0000_0000_0000_0000L ->       (* +0.0 *)
        I.xorpd ( emit_reg i.res.(0), emit_reg i.res.(0)  )
      | _ ->
        let lbl = add_float_constant f in
        I.movsd ( at_rip NO (abs_ (emit_label lbl)) 0,  emit_reg i.res.(0);  )
    end
  | Lop(Iconst_symbol s) ->
    add_used_symbol s;
    load_symbol_addr s (emit_reg i.res.(0))
  | Lop(Icall_ind) ->
    I.call ( emit_reg i.arg.(0)  );
    record_frame i.live i.dbg
  | Lop(Icall_imm(s)) ->
    add_used_symbol s;
    emit_call s;
    record_frame i.live i.dbg
  | Lop(Itailcall_ind) ->
    output_epilogue begin fun () ->
      I.jmp ( emit_reg i.arg.(0)  )
    end
  | Lop(Itailcall_imm s) ->
    if s = !function_name then
      I.jmp (  _l(emit_label !tailrec_entry_point)  )
    else begin
      output_epilogue begin fun () ->
        add_used_symbol s;
        emit_jump s
      end
    end
  | Lop(Iextcall(s, alloc)) ->
    add_used_symbol s;
    if alloc then begin
      load_symbol_addr s (_r RAX);
      emit_call "caml_c_call";
      record_frame i.live i.dbg;
      if system <> S_win64 then begin (* TODO: investigate why such a diff *)
        load_symbol_addr "caml_young_ptr" (_r R11);
        I.movq ( _mem_ptr QWORD 0 R11, _r R15;  )
      end;
    end else begin
      emit_call s
    end
  | Lop(Istackoffset n) ->
    if n < 0
    then I.addq ( _int(-n), _r RSP;  )
    else I.subq ( _int n, _r RSP;   );
    cfi_adjust_cfa_offset n;
    stack_offset := !stack_offset + n
  | Lop(Iload(chunk, addr)) ->
    let dest = i.res.(0) in
    begin match chunk with
      | Word ->
        I.movq ( emit_addressing addr QWORD i.arg 0, emit_reg dest;  )
      | Byte_unsigned ->
        I.movzbq ( emit_addressing addr BYTE i.arg 0, emit_reg dest;  )
      | Byte_signed ->
        I.movsbq ( emit_addressing addr BYTE i.arg 0, emit_reg dest;  )
      | Sixteen_unsigned ->
        I.movzwq ( emit_addressing addr WORD i.arg 0, emit_reg dest;  )
      | Sixteen_signed ->
        I.movswq ( emit_addressing addr WORD i.arg 0, emit_reg dest;  );
      | Thirtytwo_unsigned ->
        (* load to low 32 bits sets high 32 bits to 0. TODO: check ! *)
        I.movl ( emit_addressing addr DWORD i.arg 0, emit_reg32 dest;  )
      | Thirtytwo_signed ->
        I.movslq ( emit_addressing addr DWORD i.arg 0, emit_reg dest;  )
      | Single ->
        I.cvtss2sd ( emit_addressing addr REAL8 i.arg 0, emit_reg dest;  )
      | Double | Double_u ->
        I.movsd ( emit_addressing addr REAL8 i.arg 0, emit_reg dest;  )
    end
  | Lop(Istore(chunk, addr, _)) ->
    begin match chunk with
      | Word ->
        I.movq ( emit_reg i.arg.(0), emit_addressing addr QWORD i.arg 1;  )
      | Byte_unsigned | Byte_signed ->
        I.movb ( emit_reg8 i.arg.(0), emit_addressing addr BYTE i.arg 1  )
      | Sixteen_unsigned | Sixteen_signed ->
        I.movw ( emit_reg16 i.arg.(0), emit_addressing addr WORD i.arg 1  )
      | Thirtytwo_signed | Thirtytwo_unsigned ->
        I.movl ( emit_reg32 i.arg.(0), emit_addressing addr DWORD i.arg 1  )
      | Single ->
        I.cvtsd2ss ( emit_reg i.arg.(0), Regf (XMM 15);   );
        I.movss ( Regf (XMM 15), emit_addressing addr REAL8 i.arg 1  )
      | Double | Double_u ->
        I.movsd ( emit_reg i.arg.(0), emit_addressing addr REAL8 i.arg 1  )
    end
  | Lop(Ialloc n) ->
    if !fastcode_flag then begin
      let lbl_redo = new_label() in
      _llabel (emit_label lbl_redo);
      I.subq ( _int n, _r R15  );
      if !Clflags.dlcode && system <> S_win64 then begin
        load_symbol_addr "caml_young_limit" (_r RAX);
        I.cmpq ( _mem_ptr QWORD 0 RAX, _r R15  );
      end else
        I.cmpq ( at_rip NO (abs_ (emit_symbol "caml_young_limit")) 0, _r R15  );
      let lbl_call_gc = new_label() in
      let lbl_frame = record_frame_label i.live Debuginfo.none in
      I.jb ( _l( emit_label lbl_call_gc)  );
      I.leaq ( _mem_reg 8 R15, emit_reg i.res.(0)  );
      call_gc_sites :=
        { gc_lbl = lbl_call_gc;
          gc_return_lbl = lbl_redo;
          gc_frame = lbl_frame } :: !call_gc_sites
    end else begin
      begin match n with
          16  -> emit_call "caml_alloc1"
        | 24 -> emit_call "caml_alloc2"
        | 32 -> emit_call "caml_alloc3"
        | _  -> I.movq ( _int n, _r RAX  );
          emit_call "caml_allocN"
      end;
      record_frame i.live Debuginfo.none;
      I.leaq ( _mem_reg 8 R15, emit_reg i.res.(0);   )
    end
  | Lop(Iintop(Icomp cmp)) ->
    I.cmpq ( emit_reg i.arg.(1), emit_reg i.arg.(0)  );
    let b = name_for_cond_branch cmp in
    I.set b ( Reg8 AL  );
    I.movzbq ( Reg8 AL, emit_reg i.res.(0)  )
  | Lop(Iintop_imm(Icomp cmp, n)) ->
    I.cmpq ( _int n, emit_reg i.arg.(0)  );
    let b = name_for_cond_branch cmp in
    I.set b ( Reg8 AL  );
    I.movzbq ( Reg8 AL, emit_reg i.res.(0);   )
  | Lop(Iintop Icheckbound) ->
    let lbl = bound_error_label i.dbg in
    I.cmpq ( emit_reg i.arg.(1), emit_reg i.arg.(0);   );
    I.jbe ( _l ( emit_label lbl )  )
  | Lop(Iintop_imm(Icheckbound, n)) ->
    let lbl = bound_error_label i.dbg in
    I.cmpq ( _int n, emit_reg i.arg.(0);   );
    I.jbe ( _l( emit_label lbl )  )
  | Lop(Iintop(Idiv | Imod)) ->
    I.cqto ();
    I.idivq ( emit_reg i.arg.(1)  )
  | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
    (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *)
    instr_for_intop op ( Reg8 CL, emit_reg i.res.(0)  )
  | Lop(Iintop Imulh) ->
    I.imulq ( emit_reg i.arg.(1), None  )
  | Lop(Iintop op) ->
    (* We have i.arg.(0) = i.res.(0) *)
    instr_for_intop op ( emit_reg i.arg.(1), emit_reg i.res.(0)  )
  | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc ->
    I.leaq ( _mem_reg n (emit_reg64 i.arg.(0)), emit_reg i.res.(0)  )
  | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
    I.incq ( emit_reg i.res.(0)  )
  | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
    I.decq ( emit_reg i.res.(0)  )
  | Lop(Iintop_imm(op, n)) ->
    (* We have i.arg.(0) = i.res.(0) *)
    instr_for_intop op ( _int n, emit_reg i.res.(0)  )
  | Lop(Inegf) ->
    I.xorpd ( at_rip OWORD (abs_ (emit_symbol "caml_negf_mask")) 0, emit_reg i.res.(0);   )
  | Lop(Iabsf) ->
    I.andpd ( at_rip OWORD (abs_ (emit_symbol "caml_absf_mask")) 0, emit_reg i.res.(0)  )
  | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
    instr_for_floatop floatop ( emit_reg i.arg.(1), emit_reg i.res.(0);   )
  | Lop(Ifloatofint) ->
    I.cvtsi2sd  ( emit_reg i.arg.(0), emit_reg i.res.(0);   )
  | Lop(Iintoffloat) ->
    I.cvttsd2si ( emit_reg i.arg.(0), emit_reg i.res.(0);   )
  | Lop(Ispecific(Ilea addr)) ->
    I.leaq ( emit_addressing addr NO i.arg 0, emit_reg i.res.(0);   )
  | Lop(Ispecific(Istore_int(n, addr, _))) ->
    I.movq ( emit_nat n, emit_addressing addr QWORD i.arg 0;   )
  | Lop(Ispecific(Istore_symbol(s, addr, _))) ->
    assert (not !pic_code );
    (*     assert (not !Clflags.dlcode);  ONLY on Unix *)
    add_used_symbol s;
    I.movq ( _offset (abs_ (emit_symbol s)), emit_addressing addr QWORD i.arg 0  )
  | Lop(Ispecific(Ioffset_loc(n, addr))) ->
    I.addq ( _int n, emit_addressing addr QWORD i.arg 0;   )
  | Lop(Ispecific(Ifloatarithmem(op, addr))) ->
    instr_for_floatarithmem op ( emit_addressing addr REAL8 i.arg 1, emit_reg i.res.(0)  )
  | Lop(Ispecific(Ibswap size)) ->
    begin match size with
      | 16 ->
        I.xchg ( Reg8 AH, Reg8 AL  );
        I.movzwq ( emit_reg16 i.res.(0), emit_reg i.res.(0)  )
      | 32 ->
        I.bswap ( emit_reg32 i.res.(0)  );
        I.movslq ( emit_reg32 i.res.(0), emit_reg i.res.(0)  )
      | 64 ->
        I.bswap ( emit_reg i.res.(0)  )
      | _ -> assert false
    end
  | Lop(Ispecific Isqrtf) ->
    I.sqrtsd ( emit_reg i.arg.(0), emit_reg i.res.(0)  )

  | Lop(Ispecific(Ifloatsqrtf addr)) ->
    I.sqrtsd ( emit_addressing addr REAL8 i.arg 0, emit_reg i.res.(0)  )
  | Lreloadretaddr ->
    ()
  | Lreturn ->
    output_epilogue begin fun () ->
      I.ret ( )
    end
  | Llabel lbl ->
    _llabel (emit_Llabel fallthrough lbl)
  | Lbranch lbl ->
    I.jmp ( _l( emit_label lbl)  )
  | Lcondbranch(tst, lbl) ->
    begin match tst with
        Itruetest ->
        output_test_zero i.arg.(0);
        I.jne ( _l( emit_label lbl )  )
      | Ifalsetest ->
        output_test_zero i.arg.(0);
        I.je ( _l( emit_label lbl )  )
      | Iinttest cmp ->
        I.cmpq ( emit_reg i.arg.(1), emit_reg i.arg.(0)  );
        let b = name_for_cond_branch cmp in
        I.j b ( _l( emit_label lbl )  )
      | Iinttest_imm((Isigned Ceq | Isigned Cne |
                      Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
        output_test_zero i.arg.(0);
        let b = name_for_cond_branch cmp in
        I.j b ( _l ( emit_label lbl )  )
      | Iinttest_imm(cmp, n) ->
        I.cmpq ( _int n, emit_reg i.arg.(0)  );
        let b = name_for_cond_branch cmp in
        I.j b ( _l( emit_label lbl )  )
      | Ifloattest(cmp, neg) ->
        emit_float_test cmp neg i.arg lbl
      | Ioddtest ->
        I.testb ( _int 1, emit_reg8 i.arg.(0)  );
        I.jne ( _l( emit_label lbl )  )
      | Ieventest ->
        I.testb ( _int 1, emit_reg8 i.arg.(0)  );
        I.je ( _l( emit_label lbl )  )
    end
  | Lcondbranch3(lbl0, lbl1, lbl2) ->
    I.cmpq ( _int 1, emit_reg i.arg.(0)  );
    begin match lbl0 with
        None -> ()
      | Some lbl -> I.jb ( _l ( emit_label lbl )  )
    end;
    begin match lbl1 with
        None -> ()
      | Some lbl -> I.je ( _l ( emit_label lbl )  )
    end;
    begin match lbl2 with
        None -> ()
      | Some lbl -> I.jg ( _l ( emit_label lbl )  )
    end
  | Lswitch jumptbl ->
    let lbl = new_label() in
    (* rax and rdx are clobbered by the Lswitch,
       meaning that no variable that is live across the Lswitch
       is assigned to rax or rdx.  However, the argument to Lswitch
       can still be assigned to one of these two registers, so
       we must be careful not to clobber it before use. *)
    let (tmp1, tmp2) =
      if i.arg.(0).loc = Reg 0 (* rax *)
      then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*))
      else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in

    I.leaq ( at_rip NO (abs_ ( emit_label lbl )) 0, emit_reg tmp1  );
    I.movslq (
              Mem (DWORD, M64 (
                  Some (emit_reg64 i.arg.(0), 4, Some (emit_reg64 tmp1)),
                  (None, 0L))),
              emit_reg tmp2  );
    I.addq ( emit_reg tmp2, emit_reg tmp1  );
    I.jmp ( emit_reg tmp1  );

    begin match system with
      | S_macosx -> _section [".const"] None []
      | S_mingw64 | S_cygwin -> _section [".rdata"] (Some "dr") []
      | S_win64 ->
        () (* with MASM, use the text segment *)
      | _ -> _section [".rodata"] None []
    end;
    emit_align 4;
    _label (emit_label lbl);
    for i = 0 to Array.length jumptbl - 1 do
      _long (ConstSub (ConstLabel( emit_label jumptbl.(i) , None),
            ConstLabel( emit_label lbl , None)))
    done;
    _section [".text"] None []
  | Lsetuptrap lbl ->
    I.call ( _l( emit_label lbl )  )
  | Lpushtrap ->
    cfi_adjust_cfa_offset 8;
    I.pushq ( _r R14  );
    cfi_adjust_cfa_offset 8;
    I.movq ( _r RSP, _r R14  );
    stack_offset := !stack_offset + 16
  | Lpoptrap ->
    I.popq ( _r R14  );
    cfi_adjust_cfa_offset (-8);
    I.addq ( _int 8, _r RSP  );
    cfi_adjust_cfa_offset (-8);
    stack_offset := !stack_offset - 16
  | Lraise k ->
    begin match !Clflags.debug, k with
      | true, Lambda.Raise_regular ->
        emit_call "caml_raise_exn";
        record_frame Reg.Set.empty i.dbg
      | true, Lambda.Raise_reraise ->
        emit_call "caml_reraise_exn";
        record_frame Reg.Set.empty i.dbg
      | false, _
      | true, Lambda.Raise_notrace ->
        I.movq ( _r R14, _r RSP  );
        I.popq ( _r R14  );
        I.ret ( )
    end

(* DONE UNTIL HERE REVERSING ARGUMENTS *)

let rec emit_all fallthrough i =
  match i.desc with
  |  Lend -> ()
  | _ ->
      emit_instr fallthrough i;
      emit_all (Linearize.has_fallthrough i.desc) i.next

(* Emission of the profiling prelude *)

let emit_profile () =
  if system = S_gnu || system = S_linux then begin
    (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
       and rbx, rbp, r12-r15 like all C functions.  This includes
       all the registers used for argument passing, so we don't
       need to preserve other regs.  We do need to initialize rbp
       like mcount expects it, though. *)
    I.pushq ( _r R10  );
    if not fp then
      I.movq ( _r RSP, _r RBP   );
    emit_call "mcount";
    I.popq ( _r R10  )
  end

(* Emission of a function declaration *)

let fundecl fundecl =
  function_name := fundecl.fun_name;
  fastcode_flag := fundecl.fun_fast;
  tailrec_entry_point := new_label();
  stack_offset := 0;
  call_gc_sites := [];
  bound_error_sites := [];
  bound_error_call := 0;
  _text ();
  emit_align 16;
  add_def_symbol fundecl.fun_name;
  if system = S_macosx
  && not !Clflags.output_c_object
  && is_generic_function fundecl.fun_name
  then (* PR#4690 *)
    _private_extern (emit_symbol fundecl.fun_name)
  else
    _global (emit_symbol fundecl.fun_name);
  _llabel (emit_symbol fundecl.fun_name);
  emit_debug_info fundecl.fun_dbg;
  cfi_startproc ();
  if fp then begin
       I.pushq ( _r RBP  );
       cfi_adjust_cfa_offset 8;
       I.movq ( _r RSP, _r RBP  );
  end;
  if !Clflags.gprofile then emit_profile();
  if frame_required() then begin
    let n = frame_size() - 8 - (if fp then 8 else 0) in
    I.subq ( _int n, _r RSP  );
    cfi_adjust_cfa_offset n;
  end;
  _llabel (emit_label !tailrec_entry_point);
  emit_all true fundecl.fun_body;
  List.iter emit_call_gc !call_gc_sites;
  emit_call_bound_errors ();
  cfi_endproc ();
  if system = S_gnu || system = S_linux then begin
    _type (emit_symbol fundecl.fun_name) "@function";
     _size (emit_symbol fundecl.fun_name)
           (ConstSub (
              ConstLabel (".", None),
              ConstLabel  (emit_symbol fundecl.fun_name, None)))
  end

(* Emission of data *)

let emit_item = function
    Cglobal_symbol s -> _global (emit_symbol s)
  | Cdefine_symbol s ->
    add_def_symbol s;
    _label (emit_symbol s)
  | Cdefine_label lbl -> _label  (emit_data_label lbl)
  | Cint8 n -> _byte (_const n)
  | Cint16 n -> _word (_const n)
  | Cint32 n -> _long (const_nat n)
  | Cint n -> _qword (const_nat n)
  | Csingle f ->
    _long  (Const (B32, Int64.of_int32 (Int32.bits_of_float f)))
(*    emit_float32_directive ".long" (Int32.bits_of_float f) *)
  | Cdouble f ->
(*    emit_float64_directive ".quad" (Int64.bits_of_float f) *)
    _qword (Const (B64, Int64.bits_of_float f))
  | Csymbol_address s ->
    add_used_symbol s;
    _qword (ConstLabel (emit_symbol s, None))
  | Clabel_address lbl ->
    _qword (ConstLabel (emit_data_label lbl, None))
  | Cstring s ->
    _ascii s
  | Cskip n ->
    if n>0 then _space n
  | Calign n ->
    emit_align n

  (* Beginning / end of an assembly file *)

let begin_assembly() =
  arch64 := true;
  Intel_proc.reset_asm_code ();
  reset_debug_info();                   (* PR#5603 *)
  float_constants := [];
  if system = S_win64 then begin
    _extrn "caml_young_ptr" QWORD;
    _extrn "caml_young_limit" QWORD;
    _extrn "caml_exception_pointer" QWORD;
    _extrn "caml_absf_mask" QWORD;
    _extrn "caml_negf_mask" QWORD;
    _extrn "caml_call_gc" NEAR;
    _extrn "caml_c_call" NEAR;
    _extrn "caml_allocN" NEAR;
    _extrn "caml_alloc1" NEAR;
    _extrn "caml_alloc2" NEAR;
    _extrn "caml_alloc3" NEAR;
    _extrn "caml_ml_array_bound_error" NEAR;
    _extrn "caml_raise_exn" NEAR;
    _extrn "caml_reraise_exn" NEAR;
  end;


  if !Clflags.dlcode && system <> S_win64 then begin
    (* from amd64.S; could emit these constants on demand *)
    begin match system with
      | S_macosx -> _section [".literal16"] None []
      | S_mingw64 | S_cygwin -> _section [".rdata"] (Some "dr") []
      | _ -> _section [".rodata.cst8"] (Some "a") ["@progbits"]
    end;
    emit_align 16;
    _label (emit_symbol "caml_negf_mask");
    _qword (Const (B64, 0x8000000000000000L));
    _qword (Const (B64, 0L));
    emit_align 16;
    _label (emit_symbol "caml_absf_mask");
    _qword (Const (B64, 0x7FFFFFFFFFFFFFFFL));
    _qword (Const (B64, 0xFFFFFFFFFFFFFFFFL));
  end;

  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  add_def_symbol lbl_begin;
  _data ();
  emit_global_label lbl_begin;

  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
  add_def_symbol lbl_begin;
  _text ();
  emit_global_label lbl_begin;

  if system = S_macosx then I.nop (); (* PR#4690 *)
  ()



let data l =
  _data ();
  List.iter emit_item l

(* TODO: emit_string_directive *)

let end_assembly() =
  if !float_constants <> [] then begin

    begin match system with
      | S_macosx -> _section [".literal8"] None []
      | S_mingw64 | S_cygwin -> _section [".rdata"] (Some "dr") []
      | S_win64 -> _data ()
      | _ -> _section [".rodata.cst8"] (Some "a") ["@progbits"]
    end;
    List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants
  end;

  let lbl_end = Compilenv.make_symbol (Some "code_end") in
  add_def_symbol lbl_end;
  _text ();
  if system = S_macosx then I.nop (); (* suppress "ld warning: atom sorting error" *)
  emit_global_label lbl_end;
  _data ();
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  add_def_symbol lbl_end;
  emit_global_label lbl_end;
  _long (_const 0);

  let lbl = Compilenv.make_symbol (Some "frametable") in
  add_def_symbol lbl;
  emit_global_label lbl;

  emit_frames
    { efa_label = (fun l -> _qword (ConstLabel (emit_label l, None)));
      efa_16 = (fun n -> _word (_const n));
      efa_32 = (fun n -> _long (const_32 n));
      efa_word = (fun n -> _qword (Const (B64, Int64.of_int n)));
      efa_align = (emit_align);
      efa_label_rel =
        if system = S_macosx then begin
          let setcnt = ref 0 in
          fun lbl ofs ->
            incr setcnt;
            let s = Printf.sprintf "L$set$%d" !setcnt in
            _setvar ( s,
                          ConstAdd (
                            ConstLabel(emit_label lbl, None),
                            ConstAdd (_const 4, const_32 ofs))
                        );
            _long (ConstLabel (s, None))
        end else begin
          fun lbl ofs ->
            _long (ConstAdd (
                  ConstSub(
                    ConstLabel(emit_label lbl, None),
                    ConstLabel( ".", None) ),
                  const_32 ofs))
        end;
      efa_def_label = (fun l -> _label (emit_label l));
      efa_string = (fun s -> _ascii (s ^ "\000"))
    };

  if system = S_linux then
    (* Mark stack as non-executable, PR#4564 *)
    _section [".note.GNU-stack"] (Some "") [ "%progbits" ];

  if system = S_win64 then begin
    _comment "External functions";
    StringSet.iter
      (fun s ->
        if not (StringSet.mem s !symbols_defined) then
          _extrn (emit_symbol s) NEAR)
      !symbols_used;
    symbols_used := StringSet.empty;
    symbols_defined := StringSet.empty;
  end;

  _end ();

  let oc = !Emitaux.output_channel in

    let bprint_instr =
      match system with
      | S_win32 | S_win64 -> Intel_masm.bprint_instr
      | _ -> Intel_gas.bprint_instr
    in
  Intel_proc.generate_code oc bprint_instr