(**************************************************************************)
(*                                                                        *)
(*                                 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 GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Emission of Linux on Z 64-bit assembly code *)

open Misc
open Cmm
open Arch
open Proc
open Reg
open Mach
open Linear
open Emitaux
open Emitenv

let frame_size env =
  let size =
    env.stack_offset +      (* Trap frame, outgoing parameters *)
    size_int * env.f.fun_num_stack_slots.(0) +    (* Local int variables *)
    size_float * env.f.fun_num_stack_slots.(1) +  (* Local float variables *)
    (if env.f.fun_frame_required then size_addr else 0) in (* The return address *)
  Misc.align size 8

let slot_offset env loc cls =
  match loc with
    Local n ->
      if cls = 0
      then env.stack_offset +
           env.f.fun_num_stack_slots.(1) * size_float + n * size_int
      else env.stack_offset + n * size_float
  | Incoming n -> frame_size env + n
  | Outgoing n -> n
  | Domainstate _ -> assert false  (* not a stack slot *)

(* Output function call *)

let emit_call s =
  if !Clflags.pic_code then
   `	brasl	%r14, {emit_symbol s}@PLT\n`
  else
   `	brasl	%r14, {emit_symbol s}\n`

(* Output a label *)

let label_prefix = ".L"

let emit_label lbl =
  emit_string label_prefix; emit_int lbl

(* Section switching *)

let data_space = "	.section \".data\"\n"

let rodata_space = "	.section \".rodata\"\n"

let emit_named_text_section func_name =
  Emitaux.emit_named_text_section func_name '@'

(* Output a pseudo-register *)

let emit_reg r =
  match r.loc with
  | Reg r -> emit_string (register_name r)
  | _ -> fatal_error "Emit.emit_reg"


(* Special registers *)

let check_phys_reg reg_idx name =
  let reg = phys_reg reg_idx in
  assert (register_name reg_idx = name);
  reg

let reg_f15 = check_phys_reg 115 "%f15"
let reg_r7 = check_phys_reg 5 "%r7"
let reg_stack_arg_begin = check_phys_reg 7 "%r9"
let reg_stack_arg_end = check_phys_reg 6 "%r8"

let cfi_startproc () =
  if Config.asm_cfi_supported then begin
    emit_string "\t.cfi_startproc\n";
  end

let cfi_endproc () =
  if Config.asm_cfi_supported then begin
    emit_string "\t.cfi_endproc\n";
  end

let cfi_def_cfa_register reg =
  if Config.asm_cfi_supported then begin
    emit_string "\t.cfi_def_cfa_register ";
    emit_string reg;
    emit_string "\n"
  end

(* Output a stack reference *)

let emit_stack env r =
  match r.loc with
  | Stack (Domainstate n) ->
      let ofs = n + Domainstate.(idx_of_field Domain_extra_params) * 8 in
      `{emit_int ofs}(%r10)`
  | Stack s ->
      let ofs = slot_offset env s (register_class r) in
      `{emit_int ofs}(%r15)`
  | _ -> fatal_error "Emit.emit_stack"


(* Output a load of the address of a global symbol *)

let emit_load_symbol_addr reg s =
  if !Clflags.pic_code then
  `	lgrl	{emit_reg reg}, {emit_symbol s}@GOT\n`
  else
  `	larl	{emit_reg reg}, {emit_symbol s}\n`

(* Output a load or store operation *)

let emit_load_store instr addressing_mode addr n arg =
  match addressing_mode with
  | Iindexed ofs ->
      `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
  | Iindexed2 ofs ->
      `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)},{emit_reg addr.(n+1)})\n`

(* Adjust the stack pointer down by N.
   Choose the shortest instruction possible for the value of N. *)

let emit_stack_adjust n =
  let n = -n in
  if n = 0 then ()
  else if n >= 0 && n < 4096 then
    `	la	%r15, {emit_int n}(%r15)\n`
  else if n >= -0x80000 && n < 0x80000 then
    `	lay	%r15, {emit_int n}(%r15)\n`
  else
    `	agfi	%r15, {emit_int n}\n`

(* Emit a 'add immediate' *)

let emit_addimm res arg n =
  if n >= 0 && n < 4096 then
    `	la	{emit_reg res}, {emit_int n}({emit_reg arg})\n`
  else if n >= -0x80000 && n < 0x80000 then
    `	lay	{emit_reg res}, {emit_int n}({emit_reg arg})\n`
  else begin
    if arg.loc <> res.loc then
      `	lgr	{emit_reg res}, {emit_reg arg}\n`;
    `	agfi	{emit_reg res}, {emit_int n}\n`
  end

(* After a comparison, extract the result as 0 or 1 *)
(* The locgr instruction is not available in the z10 architecture,
   so this code is currently unused. *)
(*
let emit_set_comp cmp res =
    `	lghi	%r1, 1\n`;
    `	lghi	{emit_reg res}, 0\n`;
  begin match cmp with
      Ceq -> `	locgre	{emit_reg res}, %r1\n`
    | Cne -> `	locgrne	{emit_reg res}, %r1\n`
    | Cgt -> `	locgrh	{emit_reg res}, %r1\n`
    | Cle -> `	locgrnh	{emit_reg res}, %r1\n`
    | Clt -> `	locgrl	{emit_reg res}, %r1\n`
    | Cge -> `	locgrnl	{emit_reg res}, %r1\n`
  end
*)

(* Record live pointers at call points *)

let record_frame_label env live dbg =
  let lbl = new_label() in
  let live_offset = ref [] in
  Reg.Set.iter
    (function
      | {typ = Val; loc = Reg r} ->
          live_offset := (r lsl 1) + 1 :: !live_offset
      | {typ = Val; loc = Stack s} as reg ->
          live_offset := slot_offset env s (register_class reg) :: !live_offset
      | {typ = Addr} as r ->
          Misc.fatal_error ("bad GC root " ^ Reg.name r)
      | _ -> ())
    live;
  record_frame_descr ~label:lbl ~frame_size:(frame_size env)
    ~live_offset:!live_offset dbg;
  lbl

let record_frame env live dbg =
  let lbl = record_frame_label env live dbg in
  `{emit_label lbl}:`

let emit_call_gc gc =
  `{emit_label gc.gc_lbl}:`; emit_call "caml_call_gc";
  `{emit_label gc.gc_frame_lbl}:	brcl	15, {emit_label gc.gc_return_lbl}\n`

let bound_error_label env dbg =
  if !Clflags.debug then begin
    let lbl_bound_error = new_label() in
    let lbl_frame = record_frame_label env Reg.Set.empty (Dbg_other dbg) in
    env.bound_error_sites <-
      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame; }
      :: env.bound_error_sites;
   lbl_bound_error
 end else begin
    match env.bound_error_call with
    | None -> let lbl = new_label() in
      env.bound_error_call <- Some lbl;
      lbl
    | Some lbl -> lbl
 end

let emit_call_bound_error bd =
  `{emit_label bd.bd_lbl}:`; emit_call "caml_ml_array_bound_error";
  `{emit_label bd.bd_frame}:\n`

let emit_call_bound_errors env =
  List.iter emit_call_bound_error env.bound_error_sites;
  match env.bound_error_call with
  | None -> ()
  | Some lbl ->
    `{emit_label lbl}:`; emit_call "caml_ml_array_bound_error"

(* Masks for conditional branches after comparisons *)

(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = overflow*)
let branch_for_comparison = function
  | Ceq -> 0b1000 | Cne -> 0b0111 (* BRNEL is 0111 rather than 0110 *)
  | Cle -> 0b1100 | Cgt -> 0b0010
  | Cge -> 0b1010 | Clt -> 0b0100

let name_for_int_comparison = function
    Isigned cmp -> ("cgr", branch_for_comparison cmp)
  | Iunsigned cmp -> ("clgr", branch_for_comparison cmp)

let name_for_int_comparison_imm = function
    Isigned cmp -> ("cgfi", branch_for_comparison cmp)
  | Iunsigned cmp -> ("clgfi", branch_for_comparison cmp)

(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*)
let branch_for_float_comparison = function
  | CFeq  -> 0b1000
  | CFneq -> 0b0111

  | CFle  -> 0b1100
  | CFnle -> 0b0011

  | CFgt  -> 0b0010
  | CFngt -> 0b1101

  | CFge  -> 0b1010
  | CFnge -> 0b0101

  | CFlt  -> 0b0100
  | CFnlt -> 0b1011

(* Names for various instructions *)

let name_for_intop = function
    Iadd  -> "agr"
  | Isub  -> "sgr"
  | Imul  -> "msgr"
  | Iand  -> "ngr"
  | Ior   -> "ogr"
  | Ixor  -> "xgr"
  | _ -> Misc.fatal_error "Emit.Intop"

let name_for_floatop1 = function
    Inegf -> "lcdbr"
  | Iabsf -> "lpdbr"
  | _ -> Misc.fatal_error "Emit.Iopf1"

let name_for_floatop2 = function
    Iaddf -> "adbr"
  | Isubf -> "sdbr"
  | Imulf -> "mdbr"
  | Idivf -> "ddbr"
  | _ -> Misc.fatal_error "Emit.Iopf2"

let name_for_specific = function
    Imultaddf -> "madbr"
  | Imultsubf -> "msdbr"

(* Output the assembly code for an instruction *)

let emit_instr env i =
    emit_debug_info i.dbg;
    match i.desc with
      Lend -> ()
    | Lprologue ->
      let n = frame_size env in
      emit_stack_adjust n;
      if env.f.fun_frame_required then
        `	stg	%r14, {emit_int(n - size_addr)}(%r15)\n`
    | Lop(Imove | Ispill | Ireload) ->
        let src = i.arg.(0) and dst = i.res.(0) in
        if src.loc <> dst.loc then begin
           match (src, dst) with
              {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                `	lgr	{emit_reg dst}, {emit_reg src}\n`
            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
                `	ldr	{emit_reg dst}, {emit_reg src}\n`
            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
                `	stg	{emit_reg src}, {emit_stack env dst}\n`
            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
                `	std	{emit_reg src}, {emit_stack env dst}\n`
            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                `	lg	{emit_reg dst}, {emit_stack env src}\n`
            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
                `	ldy	{emit_reg dst}, {emit_stack env src}\n`
            | (_, _) ->
                fatal_error "Emit: Imove"
        end
    | Lop(Iconst_int n) ->
        if n >= -0x8000n && n <= 0x7FFFn then begin
          `	lghi	{emit_reg i.res.(0)}, {emit_nativeint n}\n`;
        end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin
          `	lgfi	{emit_reg i.res.(0)}, {emit_nativeint n}\n`;
        end else begin
          let n_lbl = new_label() in
          env.int_literals <- {n; n_lbl} :: env.int_literals;
          `	lgrl	{emit_reg i.res.(0)}, {emit_label n_lbl}\n`;
          end
    | Lop(Iconst_float fl) ->
        let lbl = new_label() in
        env.float_literals <- { fl; lbl } :: env.float_literals;
        `	larl	%r1, {emit_label lbl}\n`;
        `	ld	{emit_reg i.res.(0)}, 0(%r1)\n`
     | Lop(Iconst_symbol s) ->
        emit_load_symbol_addr i.res.(0) s
    | Lop(Icall_ind) ->
        `	basr	%r14, {emit_reg i.arg.(0)}\n`;
        `{record_frame env i.live (Dbg_other i.dbg)}\n`

    | Lop(Icall_imm { func; }) ->
        emit_call func;
        `{record_frame env i.live (Dbg_other i.dbg)}\n`
    | Lop(Itailcall_ind) ->
        let n = frame_size env in
        if env.f.fun_frame_required then
          `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
        emit_stack_adjust (-n);
        `	br	{emit_reg i.arg.(0)}\n`
    | Lop(Itailcall_imm { func; }) ->
        if func = env.f.fun_name then
          `	brcl	15, {emit_label env.f.fun_tailrec_entry_point_label}\n`
        else begin
          let n = frame_size env in
          if env.f.fun_frame_required then
            `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
          emit_stack_adjust (-n);
          if !Clflags.pic_code then
            `	brcl	15, {emit_symbol func}@PLT\n`
          else
            `	brcl	15, {emit_symbol func}\n`
        end

    | Lop(Iextcall {func; alloc; stack_ofs}) ->
        if stack_ofs > 0 then begin
          `	lgr	{emit_reg reg_stack_arg_begin}, %r15\n`;
          `	lay	{emit_reg reg_stack_arg_end}, {emit_int stack_ofs}(%r15)\n`;
          emit_load_symbol_addr reg_r7 func;
          emit_call "caml_c_call_stack_args";
          `{record_frame env i.live (Dbg_other i.dbg)}\n`
        end else if alloc then begin
          emit_load_symbol_addr reg_r7 func;
          emit_call "caml_c_call";
          `{record_frame env i.live (Dbg_other i.dbg)}\n`
        end else begin
          (* Save OCaml SP in C callee-save register *)
          `	lgr	%r12, %r15\n`;
          cfi_remember_state ();
          cfi_def_cfa_register "%r12";
          (* NB: gdb has asserts on contiguous stacks that mean it
             will not unwind through this unless we were to tag this
             calling frame with cfi_signal_frame in its definition. *)
          let offset = Domainstate.(idx_of_field Domain_c_stack) * 8 in
          `	lg	%r15, {emit_int offset}(%r10)\n`;
          emit_call func;
          `	lgr	%r15, %r12\n`;
          cfi_restore_state ()
        end

     | Lop(Istackoffset n) ->
        emit_stack_adjust n;
        env.stack_offset <- env.stack_offset + n

     | Lop(Iload { memory_chunk; addressing_mode; _ }) ->
        let loadinstr =
          match memory_chunk with
            Byte_unsigned -> "llgc"
          | Byte_signed -> "lgb"
          | Sixteen_unsigned -> "llgh"
          | Sixteen_signed -> "lgh"
          | Thirtytwo_unsigned -> "llgf"
          | Thirtytwo_signed -> "lgf"
          | Word_int | Word_val | Sixtyfour -> "lg"
          | Single -> "ley"
          | Double -> "ldy" in
        emit_load_store loadinstr addressing_mode i.arg 0 i.res.(0);
        if memory_chunk = Single then
          `	ldebr	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`

    | Lop(Istore(Single, addr, _)) ->
        `	ledbr	%f15, {emit_reg i.arg.(0)}\n`;
        emit_load_store "stey" addr i.arg 1 reg_f15
    | Lop(Istore(chunk, addr, _)) ->
        let storeinstr =
          match chunk with
            Byte_unsigned | Byte_signed -> "stcy"
          | Sixteen_unsigned | Sixteen_signed -> "sthy"
          | Thirtytwo_unsigned | Thirtytwo_signed -> "sty"
          | Word_int | Word_val | Sixtyfour -> "stg"
          | Single -> assert false
          | Double -> "stdy" in
        emit_load_store storeinstr addr i.arg 1 i.arg.(0)

    | Lop(Ialloc { bytes = n; dbginfo }) ->
        let lbl_frame_lbl = record_frame_label env i.live (Dbg_alloc dbginfo) in
        if env.f.fun_fast then begin
          let lbl_after_alloc = new_label () in
          let lbl_call_gc = new_label () in
          let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
          `	lay	%r11, {emit_int(-n)}(%r11)\n`;
          `	clg	%r11, {emit_int offset}(%r10)\n`;
          `	brcl	4, {emit_label lbl_call_gc}\n`;  (* less than *)
          `{emit_label lbl_after_alloc}:`;
          `	la	{emit_reg i.res.(0)}, 8(%r11)\n`;
          env.call_gc_sites <-
            { gc_lbl = lbl_call_gc;
              gc_return_lbl = lbl_after_alloc;
              gc_frame_lbl = lbl_frame_lbl } :: env.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`
          | _  ->
              `	lay	%r11, {emit_int(-n)}(%r11)\n`;
              `	{emit_call "caml_allocN"}\n`
          end;
          `{emit_label lbl_frame_lbl}:\n`;
          `	la	{emit_reg i.res.(0)}, 8(%r11)\n`
        end

    | Lop(Ipoll { return_label }) ->
        let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
          `	clg	%r11, {emit_int offset}(%r10)\n`;
        let lbl_call_gc = new_label () in
        let label_after_gc = match return_label with
                    | None -> new_label()
                    | Some(lbl) -> lbl in
        let lbl_frame =
          record_frame_label env i.live (Dbg_alloc [])
        in
        begin match return_label with
        | None -> `	brcl	4, {emit_label lbl_call_gc}\n`;  (* less than *)
        | Some return_label -> `	brcl	10, {emit_label return_label}\n`;  (* greater or equal *)
        end;
        env.call_gc_sites <-
          { gc_lbl = lbl_call_gc;
            gc_return_lbl = label_after_gc;
            gc_frame_lbl = lbl_frame; } :: env.call_gc_sites;
        begin match return_label with
        | None -> `{emit_label label_after_gc}:`;
        | Some _ -> `	brcl	15, {emit_label lbl_call_gc}\n`;  (* unconditional *)
        end
    | Lop(Iintop Imulh) ->
       (* Hacker's Delight section 8.3:
            mul-high-signed(a, b) = mul-high-unsigned(a, b)
                                    - a  if b < 0
                                    - b  if a < 0
          or, without branches,
            mul-high-signed(a, b) = mul-high-unsigned(a, b)
                                    - (a & (b >>s 63))
                                    - (b & (a >>s 63))
       *)
       `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
       `	mlgr	%r0, {emit_reg i.arg.(1)}\n`;
         (* r0:r1 is 128-bit unsigned product; r0 is the high bits *)
       `	srag	%r1, {emit_reg i.arg.(0)}, 63\n`;
       `	ngr	%r1, {emit_reg i.arg.(1)}\n`;
       `	sgr	%r0, %r1\n`;
       `	srag	%r1, {emit_reg i.arg.(1)}, 63\n`;
       `	ngr	%r1, {emit_reg i.arg.(0)}\n`;
       `	sgr	%r0, %r1\n`;
       `	lgr	{emit_reg i.res.(0)}, %r0\n`
    | Lop(Iintop Imod) ->
        `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
        `	dsgr	%r0, {emit_reg i.arg.(1)}\n`;
        `	lgr	{emit_reg i.res.(0)}, %r0\n`
    | Lop(Iintop Idiv) ->
        `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
        `	dsgr	%r0, {emit_reg i.arg.(1)}\n`;
        `	lgr	{emit_reg i.res.(0)}, %r1\n`
    | Lop(Iintop Ilsl) ->
        `	sllg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
    | Lop(Iintop Ilsr) ->
        `	srlg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
    | Lop(Iintop Iasr) ->
        `	srag	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
    | Lop(Iintop(Icomp cmp)) ->
        let lbl = new_label() in
        let (comp, mask) = name_for_int_comparison cmp in
        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	lghi	{emit_reg i.res.(0)}, 1\n`;
        `	brc	{emit_int mask}, {emit_label lbl}\n`;
        `	lghi	{emit_reg i.res.(0)}, 0\n`;
        `{emit_label lbl}:\n`
    | Lop(Icompf cmp) ->
        let lbl = new_label() in
        `	cdbr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	lghi	{emit_reg i.res.(0)}, 1\n`;
        let mask = branch_for_float_comparison cmp in
        `	brc	  {emit_int mask}, {emit_label lbl}\n`;
        `	lghi	{emit_reg i.res.(0)}, 0\n`;
        `{emit_label lbl}:\n`
    | Lop(Iintop (Icheckbound)) ->
        let lbl = bound_error_label env i.dbg in
        `	clgr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	brcl	12, {emit_label lbl}\n`  (* branch if unsigned le *)
    | Lop(Iintop op) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        let instr = name_for_intop op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Iintop_imm(Iadd, n)) ->
        emit_addimm i.res.(0) i.arg.(0) n
    | Lop(Iintop_imm(Isub, n)) ->
        emit_addimm i.res.(0) i.arg.(0) (-n)
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        let lbl = new_label() in
        let (comp, mask) = name_for_int_comparison_imm cmp in
        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        `	lghi	{emit_reg i.res.(0)}, 1\n`;
        `	brc	{emit_int mask}, {emit_label lbl}\n`;
        `	lghi	{emit_reg i.res.(0)}, 0\n`;
        `{emit_label lbl}:\n`
    | Lop(Iintop_imm(Icheckbound, n)) ->
       let lbl = bound_error_label env i.dbg in
       if n >= 0 then begin
        `	clgfi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        `	brcl	12, {emit_label lbl}\n`  (* branch if unsigned le *)
       end else begin
        `	brcl	15, {emit_label lbl}\n`  (* branch always *)
       end
    | Lop(Iintop_imm(Ilsl, n)) ->
        `	sllg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
    | Lop(Iintop_imm(Ilsr, n)) ->
        `	srlg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
    | Lop(Iintop_imm(Iasr, n)) ->
        `	srag	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
    | Lop(Iintop_imm(Iand, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        `	nilf	{emit_reg i.res.(0)}, {emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*))}\n`
    | Lop(Iintop_imm(Ior, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        `	oilf	{emit_reg i.res.(0)}, {emit_int n}\n`
    | Lop(Iintop_imm(Ixor, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        `	xilf	{emit_reg i.res.(0)}, {emit_int n}\n`
    | Lop(Iintop_imm(Imul, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
          `	msgfi	{emit_reg i.res.(0)}, {emit_int n}\n`
    | Lop(Iintop_imm((Imulh | Idiv | Imod), _)) ->
        assert false
    | Lop(Inegf | Iabsf as op) ->
        let instr = name_for_floatop1 op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        let instr = name_for_floatop2 op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`;
    | Lop(Ifloatofint) ->
          `	cdgbr	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
    | Lop(Iintoffloat) ->
        (* rounding method #5 = round toward 0 *)
        `	cgdbr	{emit_reg i.res.(0)}, 5, {emit_reg i.arg.(0)}\n`
    | Lop(Iopaque) ->
        assert (i.arg.(0).loc = i.res.(0).loc)
    | Lop(Ispecific sop) ->
        assert (i.arg.(2).loc = i.res.(0).loc);
        let instr = name_for_specific sop in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop (Idls_get) ->
        let ofs = Domainstate.(idx_of_field Domain_dls_root) * 8 in
        `	lg	{emit_reg i.res.(0)}, {emit_int ofs}(%r10)\n`
    | Lop (Ireturn_addr) ->
        let n = frame_size env in
        if env.f.fun_frame_required then
            `	lg	{emit_reg i.res.(0)}, {emit_int(n - size_addr)}(%r15)\n`
        else
            `	lgr	{emit_reg i.res.(0)}, %r14\n`
    | Lreloadretaddr ->
        let n = frame_size env in
        `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`
    | Lreturn ->
        let n = frame_size env in
        emit_stack_adjust (-n);
        `	br	%r14\n`
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        `	brcl	15,{emit_label lbl}\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            `	cgfi	{emit_reg i.arg.(0)}, 0\n`;
            `	brcl	7, {emit_label lbl}\n`
        | Ifalsetest ->
            `	cgfi	{emit_reg i.arg.(0)}, 0\n`;
            `	brcl	8, {emit_label lbl}\n`
        | Iinttest cmp ->
            let (comp, mask) = name_for_int_comparison cmp in
            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	brcl	{emit_int mask}, {emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            let (comp, mask) = name_for_int_comparison_imm cmp in
            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}\n`;
            `	brcl	{emit_int mask}, {emit_label lbl}\n`
        | Ifloattest cmp ->
            `	cdbr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            let mask = branch_for_float_comparison cmp in
            `	brcl	{emit_int mask}, {emit_label lbl}\n`
        | Ioddtest ->
            `	tmll	{emit_reg i.arg.(0)}, 1\n`;
            `	brcl	1, {emit_label lbl}\n`
        | Ieventest ->
            `	tmll	{emit_reg i.arg.(0)}, 1\n`;
            `	brcl	8, {emit_label lbl}\n`
        end
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
        `	cgfi	{emit_reg i.arg.(0)}, 1\n`;
        begin match lbl0 with
          None -> ()
        | Some lbl -> `	brcl	4, {emit_label lbl}\n`
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> `	brcl	8, {emit_label lbl}\n`
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> `	brcl	2, {emit_label lbl}\n`
        end
    | Lswitch jumptbl ->
        let lbl = new_label() in
        `	larl	%r0, {emit_label lbl}\n`;
        `	sllg	%r1, {emit_reg i.arg.(0)}, 2(%r0)\n`;
        `	agr	%r1, %r0\n`;
        `	lgf	%r1, 0(%r1)\n`;
        `	agr	%r1, %r0\n`;
        `	br	%r1\n`;
        emit_string rodata_space;
        `	.align	8\n`;
        `{emit_label lbl}:`;
        for i = 0 to Array.length jumptbl - 1 do
          `	.long	{emit_label jumptbl.(i)} - {emit_label lbl}\n`
        done;
        emit_named_text_section env.f.fun_name
    | Lentertrap ->
        ()
    | Ladjust_trap_depth { delta_traps } ->
        (* each trap occupies 16 bytes on the stack *)
        let delta = 16 * delta_traps in
        emit_stack_adjust delta;
        env.stack_offset <- env.stack_offset + delta
    | Lpushtrap { lbl_handler; } ->
        env.stack_offset <- env.stack_offset + 16;
        emit_stack_adjust 16;
        `	larl	%r14, {emit_label lbl_handler}\n`;
        `	stg	%r14, {emit_int size_addr}(%r15)\n`;
        `	stg	%r13, 0(%r15)\n`;
        `	lgr	%r13, %r15\n`
    | Lpoptrap ->
        `	lg	%r13, 0(%r15)\n`;
        emit_stack_adjust (-16);
        env.stack_offset <- env.stack_offset - 16
    | Lraise k ->
        begin match k with
        | Lambda.Raise_regular->
          emit_call "caml_raise_exn";
          `{record_frame env Reg.Set.empty (Dbg_raise i.dbg)}\n`
        | Lambda.Raise_reraise ->
          emit_call "caml_reraise_exn";
          `{record_frame env Reg.Set.empty (Dbg_raise i.dbg)}\n`
        | Lambda.Raise_notrace ->
          `	lg	%r1, {emit_int size_addr}(%r13)\n`;
          `	lgr	%r15, %r13\n`;
          `	lg	%r13, 0(%r15)\n`;
          emit_stack_adjust (-16);
          `	br	%r1\n`
        end


(* Emit a sequence of instructions *)

let rec emit_all env i =
  match i with
    {desc = Lend} -> ()
  | _ ->
      emit_instr env i;
      emit_all env i.next

(* Emission of a function declaration *)

let fundecl fundecl =
  let env = mk_env fundecl in
  `	.globl	{emit_symbol fundecl.fun_name}\n`;
  emit_debug_info fundecl.fun_dbg;
  emit_type_directive fundecl.fun_name "@function";
  emit_named_text_section fundecl.fun_name;
  `	.align	8\n`;
  `{emit_symbol fundecl.fun_name}:\n`;
  cfi_startproc ();

  (* Dynamic stack checking *)
  let stack_threshold_size = Config.stack_threshold * 8 in (* bytes *)
  let max_frame_size = frame_size env + fundecl.fun_extra_stack_used in
  let handle_overflow = ref None in
  if fundecl.fun_contains_nontail_calls
  || max_frame_size >= stack_threshold_size then begin
    let overflow = new_label () and ret = new_label () in
    let threshold_offset = Domainstate.stack_ctx_words * 8 + stack_threshold_size in
    let f = max_frame_size + threshold_offset in
    let offset = Domainstate.(idx_of_field Domain_current_stack) * 8 in
    `	lay	%r1, {emit_int (-f)}(%r15)\n`;
    `	clg	%r1, {emit_int offset}(%r10)\n`;
    `	brcl	4, {emit_label overflow}\n`;
    `{emit_label ret}:\n`;
    handle_overflow := Some (overflow, ret);
  end;

  emit_all env fundecl.fun_body;
  (* Emit the glue code to call the GC *)
  List.iter emit_call_gc env.call_gc_sites;
  (* Emit the glue code to handle bound errors *)
  emit_call_bound_errors env;

  begin match !handle_overflow with
  | None -> ()
  | Some (overflow,ret) -> begin
      `{emit_label overflow}:\n`;
      let s = (Config.stack_threshold + max_frame_size / 8) in
      `	lay	%r15, -8(%r15)\n`;
      `	stg	%r14, 0(%r15)\n`;
      `	lgfi	%r12, {emit_int s}\n`;
      emit_call "caml_call_realloc_stack";
      `	lg	%r14, 0(%r15)\n`;
      `	la	%r15, 8(%r15)\n`;
      `	brcl	15, {emit_label ret}\n`
    end
  end;

  cfi_endproc ();
  emit_size_directive fundecl.fun_name;
  (* Emit the numeric literals *)
  if env.float_literals <> [] || env.int_literals <> [] then begin
    emit_string rodata_space;
    `	.align	8\n`;
    List.iter
      (fun {fl; lbl} ->
        `{emit_label lbl}:`;
        emit_float64_directive ".quad" fl)
      env.float_literals;
    List.iter
      (fun {n; n_lbl} ->
        `{emit_label n_lbl}:	.quad	{emit_nativeint n}\n`)
      env.int_literals
  end

(* Emission of data *)

let declare_global_data s =
  `	.globl	{emit_symbol s}\n`;
  emit_type_directive s "@object"

let emit_item = function
    Cglobal_symbol s ->
      declare_global_data s
  | Cdefine_symbol s ->
      `{emit_symbol s}:\n`;
  | Cint8 n ->
      `	.byte	{emit_int n}\n`
  | Cint16 n ->
      `	.short	{emit_int n}\n`
  | Cint32 n ->
      `	.long	{emit_nativeint n}\n`
  | Cint n ->
      `	.quad	{emit_nativeint n}\n`
  | Csingle f ->
      emit_float32_directive ".long" (Int32.bits_of_float f)
  | Cdouble f ->
      emit_float64_directive ".quad" (Int64.bits_of_float f)
  | Csymbol_address s ->
      `	.quad	{emit_symbol s}\n`
  | Cstring s ->
      emit_bytes_directive "	.byte	" s
  | Cskip n ->
      if n > 0 then `	.space	{emit_int n}\n`
  | Calign n ->
      if n < 8 then `	.align	8\n`
               else `	.align	{emit_int n}\n`

let data l =
  emit_string data_space;
  `	.align	8\n`;
  List.iter emit_item l

(* Beginning / end of an assembly file *)

let begin_assembly() =
  reset_debug_info();
  `	.file	\"\"\n`;  (* PR#7037 *)
  (* Emit the beginning of the segments *)
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  emit_string data_space;
  `	.align	8\n`;
  declare_global_data lbl_begin;
  `{emit_symbol lbl_begin}:\n`;
  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
  emit_named_text_section lbl_begin;
  declare_global_data lbl_begin;
  `{emit_symbol lbl_begin}:\n`

let end_assembly() =
  (* Emit the end of the segments *)
  let lbl_end = Compilenv.make_symbol (Some "code_end") in
  emit_named_text_section lbl_end;
  declare_global_data lbl_end;
  `{emit_symbol lbl_end}:\n`;
  `	.long	0\n`;
  emit_string data_space;
  `	.align	8\n`;
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  declare_global_data lbl_end;
  `	.quad	0\n`;  (* PR#6329 *)
  `{emit_symbol lbl_end}:\n`;
  `	.quad	0\n`;
  (* Emit the frame descriptors *)
  emit_string data_space;  (* not rodata because relocations inside *)
  `	.align	8\n`;
  let lbl = Compilenv.make_symbol (Some "frametable") in
  declare_global_data lbl;
  `{emit_symbol lbl}:\n`;
  emit_frames
    { efa_code_label = (fun l -> `	.quad	{emit_label l}\n`);
      efa_data_label = (fun l -> `	.quad	{emit_label l}\n`);
      efa_8 = (fun n -> `	.byte	{emit_int n}\n`);
      efa_16 = (fun n -> `	.short	{emit_int n}\n`);
      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
      efa_word = (fun n -> `	.quad	{emit_int n}\n`);
      efa_align = (fun n -> `	.align	{emit_int n}\n`);
      efa_label_rel = (fun lbl ofs ->
                           `	.long	({emit_label lbl} - .) + {emit_int32 ofs}\n`);
      efa_def_label = (fun l -> `{emit_label l}:\n`);
      efa_string = (fun s -> emit_bytes_directive "	.byte	" (s ^ "\000"))
     };
  emit_size_directive lbl;
  emit_nonexecstack_note ()