# 1 "asmcomp/s390x/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 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
   (emit_string "	brasl	%r14, "; emit_symbol s; emit_string "@PLT\n")
  else
   (emit_string "	brasl	%r14, "; emit_symbol s; emit_char '\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; emit_string "(%r10)")
  | Stack s ->
      let ofs = slot_offset env s (register_class r) in
      (emit_int ofs; emit_string "(%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
  (emit_string "	lgrl	"; emit_reg reg; emit_string ", "; emit_symbol s; emit_string "@GOT\n")
  else
  (emit_string "	larl	"; emit_reg reg; emit_string ", "; emit_symbol s; emit_char '\n')

(* Output a load or store operation *)

let emit_load_store instr addressing_mode addr n arg =
  match addressing_mode with
  | Iindexed ofs ->
      (emit_char '	'; emit_string instr; emit_char '	'; emit_reg arg; emit_string ", "; emit_int ofs; emit_char '('; emit_reg addr.(n); emit_string ")\n")
  | Iindexed2 ofs ->
      (emit_char '	'; emit_string instr; emit_char '	'; emit_reg arg; emit_string ", "; emit_int ofs; emit_char '('; emit_reg addr.(n); emit_char ','; emit_reg addr.(n+1); emit_string ")\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
    (emit_string "	la	%r15, "; emit_int n; emit_string "(%r15)\n")
  else if n >= -0x80000 && n < 0x80000 then
    (emit_string "	lay	%r15, "; emit_int n; emit_string "(%r15)\n")
  else
    (emit_string "	agfi	%r15, "; emit_int n; emit_char '\n')

(* Emit a 'add immediate' *)

let emit_addimm res arg n =
  if n >= 0 && n < 4096 then
    (emit_string "	la	"; emit_reg res; emit_string ", "; emit_int n; emit_char '('; emit_reg arg; emit_string ")\n")
  else if n >= -0x80000 && n < 0x80000 then
    (emit_string "	lay	"; emit_reg res; emit_string ", "; emit_int n; emit_char '('; emit_reg arg; emit_string ")\n")
  else begin
    if arg.loc <> res.loc then
      (emit_string "	lgr	"; emit_reg res; emit_string ", "; emit_reg arg; emit_char '\n');
    (emit_string "	agfi	"; emit_reg res; emit_string ", "; emit_int n; emit_char '\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 =
    (emit_string "	lghi	%r1, 1\n");
    (emit_string "	lghi	"; emit_reg res; emit_string ", 0\n");
  begin match cmp with
      Ceq -> (emit_string "	locgre	"; emit_reg res; emit_string ", %r1\n")
    | Cne -> (emit_string "	locgrne	"; emit_reg res; emit_string ", %r1\n")
    | Cgt -> (emit_string "	locgrh	"; emit_reg res; emit_string ", %r1\n")
    | Cle -> (emit_string "	locgrnh	"; emit_reg res; emit_string ", %r1\n")
    | Clt -> (emit_string "	locgrl	"; emit_reg res; emit_string ", %r1\n")
    | Cge -> (emit_string "	locgrnl	"; emit_reg res; emit_string ", %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; emit_char ':')

let emit_call_gc gc =
  (emit_label gc.gc_lbl; emit_char ':'); emit_call "caml_call_gc";
  (emit_label gc.gc_frame_lbl; emit_string ":	brcl	15, "; emit_label gc.gc_return_lbl; emit_char '\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_char ':'); emit_call "caml_ml_array_bound_error";
  (emit_label bd.bd_frame; emit_string ":\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_char ':'); 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
        (emit_string "	stg	%r14, "; emit_int(n - size_addr); emit_string "(%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 _} ->
                (emit_string "	lgr	"; emit_reg dst; emit_string ", "; emit_reg src; emit_char '\n')
            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
                (emit_string "	ldr	"; emit_reg dst; emit_string ", "; emit_reg src; emit_char '\n')
            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
                (emit_string "	stg	"; emit_reg src; emit_string ", "; emit_stack env dst; emit_char '\n')
            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
                (emit_string "	std	"; emit_reg src; emit_string ", "; emit_stack env dst; emit_char '\n')
            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                (emit_string "	lg	"; emit_reg dst; emit_string ", "; emit_stack env src; emit_char '\n')
            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
                (emit_string "	ldy	"; emit_reg dst; emit_string ", "; emit_stack env src; emit_char '\n')
            | (_, _) ->
                fatal_error "Emit: Imove"
        end
    | Lop(Iconst_int n) ->
        if n >= -0x8000n && n <= 0x7FFFn then begin
          (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", "; emit_nativeint n; emit_char '\n');
        end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin
          (emit_string "	lgfi	"; emit_reg i.res.(0); emit_string ", "; emit_nativeint n; emit_char '\n');
        end else begin
          let n_lbl = new_label() in
          env.int_literals <- {n; n_lbl} :: env.int_literals;
          (emit_string "	lgrl	"; emit_reg i.res.(0); emit_string ", "; emit_label n_lbl; emit_char '\n');
          end
    | Lop(Iconst_float fl) ->
        let lbl = new_label() in
        env.float_literals <- { fl; lbl } :: env.float_literals;
        (emit_string "	larl	%r1, "; emit_label lbl; emit_char '\n');
        (emit_string "	ld	"; emit_reg i.res.(0); emit_string ", 0(%r1)\n")
     | Lop(Iconst_symbol s) ->
        emit_load_symbol_addr i.res.(0) s
    | Lop(Icall_ind) ->
        (emit_string "	basr	%r14, "; emit_reg i.arg.(0); emit_char '\n');
        (record_frame env i.live (Dbg_other i.dbg); emit_char '\n')

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

    | Lop(Iextcall {func; alloc; stack_ofs}) ->
        if stack_ofs > 0 then begin
          (emit_string "	lgr	"; emit_reg reg_stack_arg_begin; emit_string ", %r15\n");
          (emit_string "	lay	"; emit_reg reg_stack_arg_end; emit_string ", "; emit_int stack_ofs; emit_string "(%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); emit_char '\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); emit_char '\n')
        end else begin
          (* Save OCaml SP in C callee-save register *)
          (emit_string "	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
          (emit_string "	lg	%r15, "; emit_int offset; emit_string "(%r10)\n");
          emit_call func;
          (emit_string "	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
          (emit_string "	ldebr	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.res.(0); emit_char '\n')

    | Lop(Istore(Single, addr, _)) ->
        (emit_string "	ledbr	%f15, "; emit_reg i.arg.(0); emit_char '\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
          (emit_string "	lay	%r11, "; emit_int(-n); emit_string "(%r11)\n");
          (emit_string "	clg	%r11, "; emit_int offset; emit_string "(%r10)\n");
          (emit_string "	brcl	4, "; emit_label lbl_call_gc; emit_char '\n');  (* less than *)
          (emit_label lbl_after_alloc; emit_char ':');
          (emit_string "	la	"; emit_reg i.res.(0); emit_string ", 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_char '	'; emit_call "caml_alloc1"; emit_char '\n')
          | 24 -> (emit_char '	'; emit_call "caml_alloc2"; emit_char '\n')
          | 32 -> (emit_char '	'; emit_call "caml_alloc3"; emit_char '\n')
          | _  ->
              (emit_string "	lay	%r11, "; emit_int(-n); emit_string "(%r11)\n");
              (emit_char '	'; emit_call "caml_allocN"; emit_char '\n')
          end;
          (emit_label lbl_frame_lbl; emit_string ":\n");
          (emit_string "	la	"; emit_reg i.res.(0); emit_string ", 8(%r11)\n")
        end

    | Lop(Ipoll { return_label }) ->
        let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
          (emit_string "	clg	%r11, "; emit_int offset; emit_string "(%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 -> (emit_string "	brcl	4, "; emit_label lbl_call_gc; emit_char '\n');  (* less than *)
        | Some return_label -> (emit_string "	brcl	10, "; emit_label return_label; emit_char '\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; emit_char ':');
        | Some _ -> (emit_string "	brcl	15, "; emit_label lbl_call_gc; emit_char '\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))
       *)
       (emit_string "	lgr	%r1, "; emit_reg i.arg.(0); emit_char '\n');
       (emit_string "	mlgr	%r0, "; emit_reg i.arg.(1); emit_char '\n');
         (* r0:r1 is 128-bit unsigned product; r0 is the high bits *)
       (emit_string "	srag	%r1, "; emit_reg i.arg.(0); emit_string ", 63\n");
       (emit_string "	ngr	%r1, "; emit_reg i.arg.(1); emit_char '\n');
       (emit_string "	sgr	%r0, %r1\n");
       (emit_string "	srag	%r1, "; emit_reg i.arg.(1); emit_string ", 63\n");
       (emit_string "	ngr	%r1, "; emit_reg i.arg.(0); emit_char '\n');
       (emit_string "	sgr	%r0, %r1\n");
       (emit_string "	lgr	"; emit_reg i.res.(0); emit_string ", %r0\n")
    | Lop(Iintop Imod) ->
        (emit_string "	lgr	%r1, "; emit_reg i.arg.(0); emit_char '\n');
        (emit_string "	dsgr	%r0, "; emit_reg i.arg.(1); emit_char '\n');
        (emit_string "	lgr	"; emit_reg i.res.(0); emit_string ", %r0\n")
    | Lop(Iintop Idiv) ->
        (emit_string "	lgr	%r1, "; emit_reg i.arg.(0); emit_char '\n');
        (emit_string "	dsgr	%r0, "; emit_reg i.arg.(1); emit_char '\n');
        (emit_string "	lgr	"; emit_reg i.res.(0); emit_string ", %r1\n")
    | Lop(Iintop Ilsl) ->
        (emit_string "	sllg	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_string ", 0("; emit_reg i.arg.(1); emit_string ")\n")
    | Lop(Iintop Ilsr) ->
        (emit_string "	srlg	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_string ", 0("; emit_reg i.arg.(1); emit_string ")\n")
    | Lop(Iintop Iasr) ->
        (emit_string "	srag	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_string ", 0("; emit_reg i.arg.(1); emit_string ")\n")
    | Lop(Iintop(Icomp cmp)) ->
        let lbl = new_label() in
        let (comp, mask) = name_for_int_comparison cmp in
        (emit_char '	'; emit_string comp; emit_char '	'; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 1\n");
        (emit_string "	brc	"; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 0\n");
        (emit_label lbl; emit_string ":\n")
    | Lop(Icompf cmp) ->
        let lbl = new_label() in
        (emit_string "	cdbr	"; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 1\n");
        let mask = branch_for_float_comparison cmp in
        (emit_string "	brc	  "; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 0\n");
        (emit_label lbl; emit_string ":\n")
    | Lop(Iintop (Icheckbound)) ->
        let lbl = bound_error_label env i.dbg in
        (emit_string "	clgr	"; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
        (emit_string "	brcl	12, "; emit_label lbl; emit_char '\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_char '	'; emit_string instr; emit_char '	'; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\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_char '	'; emit_string comp; emit_char '	'; emit_reg i.arg.(0); emit_string ", "; emit_int n; emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 1\n");
        (emit_string "	brc	"; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n');
        (emit_string "	lghi	"; emit_reg i.res.(0); emit_string ", 0\n");
        (emit_label lbl; emit_string ":\n")
    | Lop(Iintop_imm(Icheckbound, n)) ->
       let lbl = bound_error_label env i.dbg in
       if n >= 0 then begin
        (emit_string "	clgfi	"; emit_reg i.arg.(0); emit_string ", "; emit_int n; emit_char '\n');
        (emit_string "	brcl	12, "; emit_label lbl; emit_char '\n')  (* branch if unsigned le *)
       end else begin
        (emit_string "	brcl	15, "; emit_label lbl; emit_char '\n')  (* branch always *)
       end
    | Lop(Iintop_imm(Ilsl, n)) ->
        (emit_string "	sllg	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_char ','; emit_int n; emit_string "(%r0)\n")
    | Lop(Iintop_imm(Ilsr, n)) ->
        (emit_string "	srlg	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_char ','; emit_int n; emit_string "(%r0)\n")
    | Lop(Iintop_imm(Iasr, n)) ->
        (emit_string "	srag	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_char ','; emit_int n; emit_string "(%r0)\n")
    | Lop(Iintop_imm(Iand, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        (emit_string "	nilf	"; emit_reg i.res.(0); emit_string ", "; emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*)); emit_char '\n')
    | Lop(Iintop_imm(Ior, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        (emit_string "	oilf	"; emit_reg i.res.(0); emit_string ", "; emit_int n; emit_char '\n')
    | Lop(Iintop_imm(Ixor, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
        (emit_string "	xilf	"; emit_reg i.res.(0); emit_string ", "; emit_int n; emit_char '\n')
    | Lop(Iintop_imm(Imul, n)) ->
        assert (i.arg.(0).loc = i.res.(0).loc);
          (emit_string "	msgfi	"; emit_reg i.res.(0); emit_string ", "; emit_int n; emit_char '\n')
    | Lop(Iintop_imm((Imulh | Idiv | Imod), _)) ->
        assert false
    | Lop(Inegf | Iabsf as op) ->
        let instr = name_for_floatop1 op in
        (emit_char '	'; emit_string instr; emit_char '	'; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_char '\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_char '	'; emit_string instr; emit_char '	'; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
    | Lop(Ifloatofint) ->
          (emit_string "	cdgbr	"; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_char '\n')
    | Lop(Iintoffloat) ->
        (* rounding method #5 = round toward 0 *)
        (emit_string "	cgdbr	"; emit_reg i.res.(0); emit_string ", 5, "; emit_reg i.arg.(0); emit_char '\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_char '	'; emit_string instr; emit_char '	'; emit_reg i.res.(0); emit_string ", "; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n')
    | Lop (Idls_get) ->
        let ofs = Domainstate.(idx_of_field Domain_dls_root) * 8 in
        (emit_string "	lg	"; emit_reg i.res.(0); emit_string ", "; emit_int ofs; emit_string "(%r10)\n")
    | Lop (Ireturn_addr) ->
        let n = frame_size env in
        if env.f.fun_frame_required then
            (emit_string "	lg	"; emit_reg i.res.(0); emit_string ", "; emit_int(n - size_addr); emit_string "(%r15)\n")
        else
            (emit_string "	lgr	"; emit_reg i.res.(0); emit_string ", %r14\n")
    | Lreloadretaddr ->
        let n = frame_size env in
        (emit_string "	lg	%r14, "; emit_int(n - size_addr); emit_string "(%r15)\n")
    | Lreturn ->
        let n = frame_size env in
        emit_stack_adjust (-n);
        (emit_string "	br	%r14\n")
    | Llabel lbl ->
        (emit_label lbl; emit_string ":\n")
    | Lbranch lbl ->
        (emit_string "	brcl	15,"; emit_label lbl; emit_char '\n')
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            (emit_string "	cgfi	"; emit_reg i.arg.(0); emit_string ", 0\n");
            (emit_string "	brcl	7, "; emit_label lbl; emit_char '\n')
        | Ifalsetest ->
            (emit_string "	cgfi	"; emit_reg i.arg.(0); emit_string ", 0\n");
            (emit_string "	brcl	8, "; emit_label lbl; emit_char '\n')
        | Iinttest cmp ->
            let (comp, mask) = name_for_int_comparison cmp in
            (emit_char '	'; emit_string comp; emit_char '	'; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
            (emit_string "	brcl	"; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n')
        | Iinttest_imm(cmp, n) ->
            let (comp, mask) = name_for_int_comparison_imm cmp in
            (emit_char '	'; emit_string comp; emit_char '	'; emit_reg i.arg.(0); emit_string ", "; emit_int n; emit_char '\n');
            (emit_string "	brcl	"; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n')
        | Ifloattest cmp ->
            (emit_string "	cdbr	"; emit_reg i.arg.(0); emit_string ", "; emit_reg i.arg.(1); emit_char '\n');
            let mask = branch_for_float_comparison cmp in
            (emit_string "	brcl	"; emit_int mask; emit_string ", "; emit_label lbl; emit_char '\n')
        | Ioddtest ->
            (emit_string "	tmll	"; emit_reg i.arg.(0); emit_string ", 1\n");
            (emit_string "	brcl	1, "; emit_label lbl; emit_char '\n')
        | Ieventest ->
            (emit_string "	tmll	"; emit_reg i.arg.(0); emit_string ", 1\n");
            (emit_string "	brcl	8, "; emit_label lbl; emit_char '\n')
        end
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
        (emit_string "	cgfi	"; emit_reg i.arg.(0); emit_string ", 1\n");
        begin match lbl0 with
          None -> ()
        | Some lbl -> (emit_string "	brcl	4, "; emit_label lbl; emit_char '\n')
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> (emit_string "	brcl	8, "; emit_label lbl; emit_char '\n')
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> (emit_string "	brcl	2, "; emit_label lbl; emit_char '\n')
        end
    | Lswitch jumptbl ->
        let lbl = new_label() in
        (emit_string "	larl	%r0, "; emit_label lbl; emit_char '\n');
        (emit_string "	sllg	%r1, "; emit_reg i.arg.(0); emit_string ", 2(%r0)\n");
        (emit_string "	agr	%r1, %r0\n");
        (emit_string "	lgf	%r1, 0(%r1)\n");
        (emit_string "	agr	%r1, %r0\n");
        (emit_string "	br	%r1\n");
        emit_string rodata_space;
        (emit_string "	.align	8\n");
        (emit_label lbl; emit_char ':');
        for i = 0 to Array.length jumptbl - 1 do
          (emit_string "	.long	"; emit_label jumptbl.(i); emit_string " - "; emit_label lbl; emit_char '\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;
        (emit_string "	larl	%r14, "; emit_label lbl_handler; emit_char '\n');
        (emit_string "	stg	%r14, "; emit_int size_addr; emit_string "(%r15)\n");
        (emit_string "	stg	%r13, 0(%r15)\n");
        (emit_string "	lgr	%r13, %r15\n")
    | Lpoptrap ->
        (emit_string "	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); emit_char '\n')
        | Lambda.Raise_reraise ->
          emit_call "caml_reraise_exn";
          (record_frame env Reg.Set.empty (Dbg_raise i.dbg); emit_char '\n')
        | Lambda.Raise_notrace ->
          (emit_string "	lg	%r1, "; emit_int size_addr; emit_string "(%r13)\n");
          (emit_string "	lgr	%r15, %r13\n");
          (emit_string "	lg	%r13, 0(%r15)\n");
          emit_stack_adjust (-16);
          (emit_string "	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
  (emit_string "	.globl	"; emit_symbol fundecl.fun_name; emit_char '\n');
  emit_debug_info fundecl.fun_dbg;
  emit_type_directive fundecl.fun_name "@function";
  emit_named_text_section fundecl.fun_name;
  (emit_string "	.align	8\n");
  (emit_symbol fundecl.fun_name; emit_string ":\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
    (emit_string "	lay	%r1, "; emit_int (-f); emit_string "(%r15)\n");
    (emit_string "	clg	%r1, "; emit_int offset; emit_string "(%r10)\n");
    (emit_string "	brcl	4, "; emit_label overflow; emit_char '\n');
    (emit_label ret; emit_string ":\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; emit_string ":\n");
      let s = (Config.stack_threshold + max_frame_size / 8) in
      (emit_string "	lay	%r15, -8(%r15)\n");
      (emit_string "	stg	%r14, 0(%r15)\n");
      (emit_string "	lgfi	%r12, "; emit_int s; emit_char '\n');
      emit_call "caml_call_realloc_stack";
      (emit_string "	lg	%r14, 0(%r15)\n");
      (emit_string "	la	%r15, 8(%r15)\n");
      (emit_string "	brcl	15, "; emit_label ret; emit_char '\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;
    (emit_string "	.align	8\n");
    List.iter
      (fun {fl; lbl} ->
        (emit_label lbl; emit_char ':');
        emit_float64_directive ".quad" fl)
      env.float_literals;
    List.iter
      (fun {n; n_lbl} ->
        (emit_label n_lbl; emit_string ":	.quad	"; emit_nativeint n; emit_char '\n'))
      env.int_literals
  end

(* Emission of data *)

let declare_global_data s =
  (emit_string "	.globl	"; emit_symbol s; emit_char '\n');
  emit_type_directive s "@object"

let emit_item = function
    Cglobal_symbol s ->
      declare_global_data s
  | Cdefine_symbol s ->
      (emit_symbol s; emit_string ":\n");
  | Cint8 n ->
      (emit_string "	.byte	"; emit_int n; emit_char '\n')
  | Cint16 n ->
      (emit_string "	.short	"; emit_int n; emit_char '\n')
  | Cint32 n ->
      (emit_string "	.long	"; emit_nativeint n; emit_char '\n')
  | Cint n ->
      (emit_string "	.quad	"; emit_nativeint n; emit_char '\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 ->
      (emit_string "	.quad	"; emit_symbol s; emit_char '\n')
  | Cstring s ->
      emit_bytes_directive "	.byte	" s
  | Cskip n ->
      if n > 0 then (emit_string "	.space	"; emit_int n; emit_char '\n')
  | Calign n ->
      if n < 8 then (emit_string "	.align	8\n")
               else (emit_string "	.align	"; emit_int n; emit_char '\n')

let data l =
  emit_string data_space;
  (emit_string "	.align	8\n");
  List.iter emit_item l

(* Beginning / end of an assembly file *)

let begin_assembly() =
  reset_debug_info();
  (emit_string "	.file	\"\"\n");  (* PR#7037 *)
  (* Emit the beginning of the segments *)
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  emit_string data_space;
  (emit_string "	.align	8\n");
  declare_global_data lbl_begin;
  (emit_symbol lbl_begin; emit_string ":\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; emit_string ":\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; emit_string ":\n");
  (emit_string "	.long	0\n");
  emit_string data_space;
  (emit_string "	.align	8\n");
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  declare_global_data lbl_end;
  (emit_string "	.quad	0\n");  (* PR#6329 *)
  (emit_symbol lbl_end; emit_string ":\n");
  (emit_string "	.quad	0\n");
  (* Emit the frame descriptors *)
  emit_string data_space;  (* not rodata because relocations inside *)
  (emit_string "	.align	8\n");
  let lbl = Compilenv.make_symbol (Some "frametable") in
  declare_global_data lbl;
  (emit_symbol lbl; emit_string ":\n");
  emit_frames
    { efa_code_label = (fun l -> (emit_string "	.quad	"; emit_label l; emit_char '\n'));
      efa_data_label = (fun l -> (emit_string "	.quad	"; emit_label l; emit_char '\n'));
      efa_8 = (fun n -> (emit_string "	.byte	"; emit_int n; emit_char '\n'));
      efa_16 = (fun n -> (emit_string "	.short	"; emit_int n; emit_char '\n'));
      efa_32 = (fun n -> (emit_string "	.long	"; emit_int32 n; emit_char '\n'));
      efa_word = (fun n -> (emit_string "	.quad	"; emit_int n; emit_char '\n'));
      efa_align = (fun n -> (emit_string "	.align	"; emit_int n; emit_char '\n'));
      efa_label_rel = (fun lbl ofs ->
                           (emit_string "	.long	("; emit_label lbl; emit_string " - .) + "; emit_int32 ofs; emit_char '\n'));
      efa_def_label = (fun l -> (emit_label l; emit_string ":\n"));
      efa_string = (fun s -> emit_bytes_directive "	.byte	" (s ^ "\000"))
     };
  emit_size_directive lbl;
  emit_nonexecstack_note ()