ocaml/asmcomp/amd64/emit.mlp

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            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.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Emission of x86-64 (AMD 64) assembly code *)

open Misc
open Cmm
open Arch
open Proc
open Reg
open Mach
open Linearize
open Emitaux

let macosx =
  match Config.system with
  | "macosx" -> true
  | _ -> false


(* 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 () =
  !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)
    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 emit_symbol s =
    if macosx then emit_string "_"; 
    Emitaux.emit_symbol '$' s

let emit_call s =
  if !Clflags.dlcode && not macosx
  then `call	{emit_symbol s}@PLT`
  else `call	{emit_symbol s}`

let emit_jump s =
  if !Clflags.dlcode && not macosx
  then `jmp	{emit_symbol s}@PLT`
  else `jmp	{emit_symbol s}`

let load_symbol_addr s =
  if !Clflags.dlcode
  then `movq	{emit_symbol s}@GOTPCREL(%rip)`
  else if !pic_code
  then `leaq	{emit_symbol s}(%rip)`
  else `movq	${emit_symbol s}`

(* Output a label *)

let emit_label lbl =
  emit_string ".L"; emit_int lbl

(* Output a .align directive. *)

let emit_align n =
    let n = if macosx then Misc.log2 n else n in
  `	.align	{emit_int n}\n`

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 r } ->
      emit_string (register_name r)
  | { loc = Stack s } as r ->
      let ofs = slot_offset s (register_class r) in
      `{emit_int 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 =
  [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b";
     "%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |]
let reg_low_16_name =
  [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w";
     "%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |]
let reg_low_32_name =
  [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d";
     "%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |]

let emit_subreg tbl r =
  match r.loc with
    Reg r when r < 13 ->
      emit_string tbl.(r)
  | Stack s ->
      let ofs = slot_offset s (register_class r) in
      `{emit_int ofs}(%rsp)`
  | _ ->
      assert false

let emit_reg8 r = emit_subreg reg_low_8_name r
let emit_reg16 r = emit_subreg reg_low_16_name r
let emit_reg32 r = emit_subreg reg_low_32_name r

(* Output an addressing mode *)

let emit_addressing addr r n =
  match addr with
  | Ibased _ when !Clflags.dlcode -> assert false
  | Ibased(s, d) ->
      `{emit_symbol s}`;
      if d <> 0 then ` + {emit_int d}`;
      `(%rip)`
  | Iindexed d ->
      if d <> 0 then emit_int d;
      `({emit_reg r.(n)})`
  | Iindexed2 d ->
      if d <> 0 then emit_int d;
      `({emit_reg r.(n)}, {emit_reg r.(n+1)})`
  | Iscaled(2, d) ->
      if d <> 0 then emit_int d;
      `({emit_reg r.(n)}, {emit_reg r.(n)})`
  | Iscaled(scale, d) ->
      if d <> 0 then emit_int d;
      `(, {emit_reg r.(n)}, {emit_int scale})`
  | Iindexed2scaled(scale, d) ->
      if d <> 0 then emit_int d;
      `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})`

(* 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 `{emit_label lbl}:\n`

(* 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 =
  `{emit_label gc.gc_lbl}:	{emit_call "caml_call_gc"}\n`;
  `{emit_label gc.gc_frame}:	jmp	{emit_label gc.gc_return_lbl}\n`

(* 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 =
  `{emit_label bd.bd_lbl}:	{emit_call "caml_ml_array_bound_error"}\n`;
  `{emit_label bd.bd_frame}:\n`

let emit_call_bound_errors () =
  List.iter emit_call_bound_error !bound_error_sites;
  if !bound_error_call > 0 then
    `{emit_label !bound_error_call}:	{emit_call "caml_ml_array_bound_error"}\n`

(* Names for instructions *)

let instr_for_intop = function
    Iadd -> "addq"
  | Isub -> "subq"
  | Imul -> "imulq"
  | Iand -> "andq"
  | Ior -> "orq"
  | Ixor -> "xorq"
  | Ilsl -> "salq"
  | Ilsr -> "shrq"
  | Iasr -> "sarq"
  | _ -> assert false

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

let instr_for_floatarithmem = function
    Ifloatadd -> "addsd"
  | Ifloatsub -> "subsd"
  | Ifloatmul -> "mulsd"
  | Ifloatdiv -> "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 r -> `	testq	{emit_reg arg}, {emit_reg arg}\n`
  | _     -> `	cmpq	$0, {emit_reg arg}\n`

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

let emit_float_test cmp neg arg lbl =
  begin match cmp with
  | Ceq | Cne -> `	ucomisd	`
  | _         -> `	comisd	`
  end;
  `{emit_reg arg.(1)}, {emit_reg arg.(0)}\n`;
  let (branch_opcode, need_jp) =
    match (cmp, neg) with
      (Ceq, false) -> ("je", true)
    | (Ceq, true)  -> ("jne", true)
    | (Cne, false) -> ("jne", true)
    | (Cne, true)  -> ("je", true)
    | (Clt, false) -> ("jb", true)
    | (Clt, true)  -> ("jae", true)
    | (Cle, false) -> ("jbe", true)
    | (Cle, true)  -> ("ja", true)
    | (Cgt, false) -> ("ja", false)
    | (Cgt, true)  -> ("jbe", false)
    | (Cge, false) -> ("jae", true)
    | (Cge, true)  -> ("jb", false) in
  let branch_if_not_comparable =
    if cmp = Cne then not neg else neg in
  if need_jp then
    if branch_if_not_comparable then begin
      `	jp	{emit_label lbl}\n`;
      `	{emit_string branch_opcode}	{emit_label lbl}\n`
    end else begin
      let next = new_label() in
      `	jp	{emit_label next}\n`;
      `	{emit_string branch_opcode}	{emit_label lbl}\n`;
      `{emit_label next}:\n`
    end
  else begin
    `	{emit_string branch_opcode}	{emit_label lbl}\n`
  end

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

let output_epilogue () =
  if frame_required() then begin
    let n = frame_size() - 8 in
    `	addq	${emit_int n}, %rsp\n`
  end

(* 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

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

let emit_instr fallthrough i =
    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
          if src.typ = Float then
            `	movsd	{emit_reg src}, {emit_reg dst}\n`
          else
              `	movq	{emit_reg src}, {emit_reg dst}\n`
        end
    | Lop(Iconst_int n) ->
        if n = 0n then begin
          match i.res.(0).loc with
            Reg n -> `	xorq	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
          | _     -> `	movq	$0, {emit_reg i.res.(0)}\n`
        end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then
          `	movq	${emit_nativeint n}, {emit_reg i.res.(0)}\n`
        else
          `	movabsq	${emit_nativeint n}, {emit_reg i.res.(0)}\n`
    | Lop(Iconst_float s) ->
        begin match Int64.bits_of_float (float_of_string s) with
        | 0x0000_0000_0000_0000L ->       (* +0.0 *)
          `	xorpd	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
        | _ ->
          let lbl = new_label() in
          float_constants := (lbl, s) :: !float_constants;
          `	movlpd	{emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
        end
    | Lop(Iconst_symbol s) ->
        `	{load_symbol_addr s}, {emit_reg i.res.(0)}\n`
    | Lop(Icall_ind) ->
        `	call	*{emit_reg i.arg.(0)}\n`;
        record_frame i.live i.dbg
    | Lop(Icall_imm(s)) ->
        `	{emit_call s}\n`;
        record_frame i.live i.dbg
    | Lop(Itailcall_ind) ->
        output_epilogue();
        `	jmp	*{emit_reg i.arg.(0)}\n`
    | Lop(Itailcall_imm s) ->
        if s = !function_name then
          `	jmp	{emit_label !tailrec_entry_point}\n`
        else begin
          output_epilogue();
          `	{emit_jump s}\n`
        end
    | Lop(Iextcall(s, alloc)) ->
        if alloc then begin
          `	{load_symbol_addr s}, %rax\n`;
          `	{emit_call "caml_c_call"}\n`;
          record_frame i.live i.dbg
        end else begin
          `	{emit_call s}\n`
        end
    | Lop(Istackoffset n) ->
        if n < 0
        then `	addq	${emit_int(-n)}, %rsp\n`
        else `	subq	${emit_int(n)}, %rsp\n`;
        stack_offset := !stack_offset + n
    | Lop(Iload(chunk, addr)) ->
        let dest = i.res.(0) in
        begin match chunk with
          | Word ->
              `	movq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Byte_unsigned ->
              `	movzbq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Byte_signed ->
              `	movsbq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Sixteen_unsigned ->
              `	movzwq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Sixteen_signed ->
              `	movswq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Thirtytwo_unsigned ->
              `	movl	{emit_addressing addr i.arg 0}, {emit_reg32 dest}\n`
          | Thirtytwo_signed ->
              `	movslq	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Single ->
            `	cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
          | Double | Double_u ->
            `	movlpd	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
        end
    | Lop(Istore(chunk, addr)) ->
        begin match chunk with
          | Word ->
            `	movq	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
          | Byte_unsigned | Byte_signed ->
            `	movb	{emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
          | Sixteen_unsigned | Sixteen_signed ->
            `	movw	{emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
          | Thirtytwo_signed | Thirtytwo_unsigned ->
            `	movl	{emit_reg32 i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
          | Single ->
            `	cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`;
            `	movss	%xmm15, {emit_addressing addr i.arg 1}\n`
          | Double | Double_u ->
            `	movlpd	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
        end
    | Lop(Ialloc n) ->
        if !fastcode_flag then begin
          let lbl_redo = new_label() in
          `{emit_label lbl_redo}:	subq	${emit_int n}, %r15\n`;
          if !Clflags.dlcode then begin
            `	{load_symbol_addr "caml_young_limit"}, %rax\n`;
            `	cmpq	(%rax), %r15\n`;
          end else
            `	cmpq	{emit_symbol "caml_young_limit"}(%rip), %r15\n`;
          let lbl_call_gc = new_label() in
          let lbl_frame = record_frame_label i.live Debuginfo.none in
          `	jb	{emit_label lbl_call_gc}\n`;
          `	leaq	8(%r15), {emit_reg i.res.(0)}\n`;
          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"}\n`
          | 24 -> `	{emit_call "caml_alloc2"}\n`
          | 32 -> `	{emit_call "caml_alloc3"}\n`
          | _  -> `	movq	${emit_int n}, %rax\n`;
                  `	{emit_call "caml_allocN"}\n`
          end;
          `{record_frame i.live Debuginfo.none}	leaq	8(%r15), {emit_reg i.res.(0)}\n`
        end
    | Lop(Iintop(Icomp cmp)) ->
        `	cmpq	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
        let b = name_for_cond_branch cmp in
        `	set{emit_string b}	%al\n`;
        `	movzbq	%al, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        `	cmpq	${emit_int n}, {emit_reg i.arg.(0)}\n`;
        let b = name_for_cond_branch cmp in
        `	set{emit_string b}	%al\n`;
        `	movzbq	%al, {emit_reg i.res.(0)}\n`
    | Lop(Iintop Icheckbound) ->
        let lbl = bound_error_label i.dbg in
        `	cmpq	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
        `	jbe	{emit_label lbl}\n`
    | Lop(Iintop_imm(Icheckbound, n)) ->
        let lbl = bound_error_label i.dbg in
        `	cmpq	${emit_int n}, {emit_reg i.arg.(0)}\n`;
        `	jbe	{emit_label lbl}\n`
    | Lop(Iintop(Idiv | Imod)) ->
        `	cqto\n`;
        `	idivq	{emit_reg i.arg.(1)}\n`
    | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
        (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *)
        `	{emit_string(instr_for_intop op)}	%cl, {emit_reg i.res.(0)}\n`
    | Lop(Iintop op) ->
        (* We have i.arg.(0) = i.res.(0) *)
        `	{emit_string(instr_for_intop op)}	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc ->
        `	leaq	{emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
        `	incq	{emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
        `	decq	{emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Idiv, n)) ->
        (* Note: i.arg.(0) = i.res.(0) = rdx  (cf. selection.ml) *)
        let l = Misc.log2 n in
        `	movq	{emit_reg i.arg.(0)}, %rax\n`;
        `	addq	${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
        `	testq	%rax, %rax\n`;
        `	cmovns	%rax, {emit_reg i.arg.(0)}\n`;
        `	sarq	${emit_int l}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Imod, n)) ->
        (* Note: i.arg.(0) = i.res.(0) = rdx  (cf. selection.ml) *)
        `	movq	{emit_reg i.arg.(0)}, %rax\n`;
        `	testq	%rax, %rax\n`;
        `	leaq	{emit_int(n-1)}(%rax), %rax\n`;
        `	cmovns	{emit_reg i.arg.(0)}, %rax\n`;
        `	andq	${emit_int (-n)}, %rax\n`;
        `	subq	%rax, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(op, n)) ->
        (* We have i.arg.(0) = i.res.(0) *)
        `	{emit_string(instr_for_intop op)}	${emit_int n}, {emit_reg i.res.(0)}\n`
    | Lop(Inegf) ->
        `	xorpd	{emit_symbol "caml_negf_mask"}(%rip), {emit_reg i.res.(0)}\n`
    | Lop(Iabsf) ->
        `	andpd	{emit_symbol "caml_absf_mask"}(%rip), {emit_reg i.res.(0)}\n`
    | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
        `	{emit_string(instr_for_floatop floatop)}	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Ifloatofint) ->
        `	cvtsi2sdq	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintoffloat) ->
        `	cvttsd2siq	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Ispecific(Ilea addr)) ->
        `	leaq	{emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
    | Lop(Ispecific(Istore_int(n, addr))) ->
        `	movq	${emit_nativeint n}, {emit_addressing addr i.arg 0}\n`
    | Lop(Ispecific(Istore_symbol(s, addr))) ->
        assert (not !pic_code && not !Clflags.dlcode);
        `	movq	${emit_symbol s}, {emit_addressing addr i.arg 0}\n`
    | Lop(Ispecific(Ioffset_loc(n, addr))) ->
        `	addq	${emit_int n}, {emit_addressing addr i.arg 0}\n`
    | Lop(Ispecific(Ifloatarithmem(op, addr))) ->
        `	{emit_string(instr_for_floatarithmem op)}	{emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n`
    | Lreloadretaddr ->
        ()
    | Lreturn ->
        output_epilogue();
        `	ret\n`
    | Llabel lbl ->
        `{emit_Llabel fallthrough lbl}:\n`
    | Lbranch lbl ->
        `	jmp	{emit_label lbl}\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            output_test_zero i.arg.(0);
            `	jne	{emit_label lbl}\n`
        | Ifalsetest ->
            output_test_zero i.arg.(0);
            `	je	{emit_label lbl}\n`
        | Iinttest cmp ->
            `	cmpq	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
            let b = name_for_cond_branch cmp in
            `	j{emit_string b}	{emit_label lbl}\n`
        | 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
            `	j{emit_string b}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            `	cmpq	${emit_int n}, {emit_reg i.arg.(0)}\n`;
            let b = name_for_cond_branch cmp in
            `	j{emit_string b}	{emit_label lbl}\n`
        | Ifloattest(cmp, neg) ->
            emit_float_test cmp neg i.arg lbl
        | Ioddtest ->
            `	testb	$1, {emit_reg8 i.arg.(0)}\n`;
            `	jne	{emit_label lbl}\n`
        | Ieventest ->
            `	testb	$1, {emit_reg8 i.arg.(0)}\n`;
            `	je	{emit_label lbl}\n`
        end
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
            `	cmpq	$1, {emit_reg i.arg.(0)}\n`;
            begin match lbl0 with
              None -> ()
            | Some lbl -> `	jb	{emit_label lbl}\n`
            end;
            begin match lbl1 with
              None -> ()
            | Some lbl -> `	je	{emit_label lbl}\n`
            end;
            begin match lbl2 with
              None -> ()
            | Some lbl -> `	jg	{emit_label lbl}\n`
            end
    | Lswitch jumptbl ->
        let lbl = new_label() in
        if !pic_code || !Clflags.dlcode then begin
          (* PR#4424: r11 is known to be clobbered by the Lswitch,
             meaning that no variable that is live across the Lswitch
             is assigned to r11.  However, the argument to Lswitch
             can still be assigned to r11, so we need to special-case 
             this situation. *)
          if i.arg.(0).loc = Reg 9 (* ie r11, cf amd64/proc.ml *) then begin
            `	salq	$3, %r11\n`;
            `	pushq	%r11\n`;
            `	leaq	{emit_label lbl}(%rip), %r11\n`;
            `	addq	0(%rsp), %r11\n`;
            `	addq	$8, %rsp\n`;
            `	jmp	*(%r11)\n`
          end else begin
            `	leaq	{emit_label lbl}(%rip), %r11\n`;
            `	jmp	*(%r11, {emit_reg i.arg.(0)}, 8)\n`
          end
        end else begin
          `	jmp	*{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`
        end;
        if macosx
        then `	.const\n`
        else `	.section .rodata\n`;
        emit_align 8;
        `{emit_label lbl}:`;
        for i = 0 to Array.length jumptbl - 1 do
          `	.quad	{emit_label jumptbl.(i)}\n`
        done;
        `	.text\n`
    | Lsetuptrap lbl ->
        `	call	{emit_label lbl}\n`
    | Lpushtrap ->
        `	pushq	%r14\n`;
        `	movq	%rsp, %r14\n`;
        stack_offset := !stack_offset + 16
    | Lpoptrap ->
        `	popq	%r14\n`;
        `	addq	$8, %rsp\n`;
        stack_offset := !stack_offset - 16
    | Lraise ->
        if !Clflags.debug then begin
          `	{emit_call "caml_raise_exn"}\n`;
          record_frame Reg.Set.empty i.dbg
        end else begin
          `	movq	%r14, %rsp\n`;
          `	popq	%r14\n`;
          `	ret\n`
        end

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 floating-point constants *)

let emit_float_constant (lbl, cst) =
  `{emit_label lbl}:	.double	{emit_string cst}\n`

(* Emission of the profiling prelude *)

let emit_profile () =
  match Config.system with
  | "linux" | "gnu" ->
      (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
         and rbx, rbp, r12-r15 like all C functions.
         We need to preserve r10 and r11 ourselves, since Caml can
         use them for argument passing. *)
      `	pushq	%r10\n`;
      `	movq	%rsp, %rbp\n`;
      `	pushq	%r11\n`;
      `	{emit_call "mcount"}\n`;
      `	popq	%r11\n`;
      `	popq	%r10\n`
  | _ ->
      () (*unsupported yet*)

(* 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;
  float_constants := [];
  call_gc_sites := [];
  bound_error_sites := [];
  bound_error_call := 0;
  `	.text\n`;
  emit_align 16;
  if macosx && is_generic_function fundecl.fun_name
  then (* PR#4690 *)
    `	.private_extern	{emit_symbol fundecl.fun_name}\n`
  else
    `	.globl	{emit_symbol fundecl.fun_name}\n`;
  `{emit_symbol fundecl.fun_name}:\n`;
  if !Clflags.gprofile then emit_profile();
  if frame_required() then begin
    let n = frame_size() - 8 in
    `	subq	${emit_int n}, %rsp\n`
  end;
  `{emit_label !tailrec_entry_point}:\n`;
  emit_all true fundecl.fun_body;
  List.iter emit_call_gc !call_gc_sites;
  emit_call_bound_errors ();
  if !float_constants <> [] then begin
    if macosx
    then `	.literal8\n`
    else `	.section	.rodata.cst8,\"a\",@progbits\n`;
    List.iter emit_float_constant !float_constants
  end;
  match Config.system with
    "linux" | "gnu" ->
      `	.type	{emit_symbol fundecl.fun_name},@function\n`;
      `	.size	{emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n`
  | _ -> ()

(* Emission of data *)

let emit_item = function
    Cglobal_symbol s ->
      `	.globl	{emit_symbol s}\n`;
  | Cdefine_symbol s ->
      `{emit_symbol s}:\n`
  | Cdefine_label lbl ->
      `{emit_label (100000 + lbl)}:\n`
  | Cint8 n ->
      `	.byte	{emit_int n}\n`
  | Cint16 n ->
      `	.word	{emit_int n}\n`
  | Cint32 n ->
      `	.long	{emit_nativeint n}\n`
  | Cint n ->
      `	.quad	{emit_nativeint n}\n`
  | Csingle f ->
      `	.float	{emit_string f}\n`
  | Cdouble f ->
      `	.double	{emit_string f}\n`
  | Csymbol_address s ->
      `	.quad	{emit_symbol s}\n`
  | Clabel_address lbl ->
      `	.quad	{emit_label (100000 + lbl)}\n`
  | Cstring s ->
      emit_string_directive "	.ascii	" s
  | Cskip n ->
      if n > 0 then `	.space	{emit_int n}\n`
  | Calign n ->
      emit_align n

let data l =
  `	.data\n`;
  List.iter emit_item l

(* Beginning / end of an assembly file *)

let begin_assembly() =
  if !Clflags.dlcode then begin
    (* from amd64.S; could emit these constants on demand *)
    if macosx then begin
        `	.literal16\n`;
        `	.align  4\n`;
        `caml_negf_mask:	.quad   0x8000000000000000, 0\n`;
        `	.align  4\n`;
        `caml_absf_mask:	.quad   0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`;
    end else begin
        `	.section        .rodata.cst8,\"a\",@progbits\n`;
        `	.align  16\n`;
        `caml_negf_mask:	.quad   0x8000000000000000, 0\n`;
        `	.align  16\n`;
        `caml_absf_mask:	.quad   0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`;
    end;
  end;
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  `	.data\n`;
  `	.globl	{emit_symbol lbl_begin}\n`;
  `{emit_symbol lbl_begin}:\n`;
  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
  `	.text\n`;
  `	.globl	{emit_symbol lbl_begin}\n`;
  `{emit_symbol lbl_begin}:\n`;
  if macosx then `	nop\n` (* PR#4690 *)

let end_assembly() =
  let lbl_end = Compilenv.make_symbol (Some "code_end") in
  `	.text\n`;
  if macosx then `	nop\n`; (* suppress "ld warning: atom sorting error" *)
  `	.globl	{emit_symbol lbl_end}\n`;
  `{emit_symbol lbl_end}:\n`;
  `	.data\n`;
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  `	.globl	{emit_symbol lbl_end}\n`;
  `{emit_symbol lbl_end}:\n`;
  `	.long	0\n`;
  let lbl = Compilenv.make_symbol (Some "frametable") in
  `	.globl	{emit_symbol lbl}\n`;
  `{emit_symbol lbl}:\n`;
  emit_frames
    { efa_label = (fun l -> `	.quad	{emit_label l}\n`);
      efa_16 = (fun n -> `	.word	{emit_int n}\n`);
      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
      efa_word = (fun n -> `	.quad	{emit_int n}\n`);
      efa_align = emit_align;
      efa_label_rel =
        if macosx then begin
          let setcnt = ref 0 in
          fun lbl ofs ->
            incr setcnt;
            `	.set	L$set${emit_int !setcnt}, ({emit_label lbl} - .) + {emit_int32 ofs}\n`;
            `	.long L$set${emit_int !setcnt}\n`
        end else begin
	  fun lbl ofs ->
             `	.long	({emit_label lbl} - .) + {emit_int32 ofs}\n`
	end;
      efa_def_label = (fun l -> `{emit_label l}:\n`);
      efa_string = (fun s -> emit_string_directive "	.asciz	" s) };
  if Config.system = "linux" then
    (* Mark stack as non-executable, PR#4564 *)
    `	.section .note.GNU-stack,\"\",%progbits\n`