(**************************************************************************)
(*                                                                        *)
(*                                 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 PowerPC assembly code *)

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

(* Reserved space at bottom of stack *)

let reserved_stack_space = 32

(* Layout of the stack.  The stack is kept 16-aligned. *)

let initial_stack_offset f =
  if f.fun_frame_required then
    reserved_stack_space +                    (* Including the return address *)
    size_int * f.fun_num_stack_slots.(0) +    (* Local int variables *)
    size_float * f.fun_num_stack_slots.(1)    (* Local float variables *)
  else
    0

let frame_size env =
  let size =
    env.stack_offset +                     (* Trap frame, outgoing parameters *)
    initial_stack_offset env.f in
  Misc.align size 16

let slot_offset env loc cls =
  match loc with
  | Local n ->
      reserved_stack_space + env.stack_offset +
      (if cls = 0 then env.f.fun_num_stack_slots.(1) * size_float + n * size_int
                  else n * size_float)
  | Incoming n ->
    (* Callee's [reserved_stack_space] is included in [frame_size].
       To access incoming arguments, add caller's [reserved_stack_space]. *)
      frame_size env + reserved_stack_space + n
  | Outgoing n -> reserved_stack_space + n
  | Domainstate _ -> assert false  (* not a stack slot *)

let retaddr_offset env = frame_size env + 16

let toc_save_offset env = frame_size env + 8

let trap_size = 16

(* 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 toc_space =
  " .section \".toc\",\"aw\"\n"

let emit_named_text_section func_name =
  Emitaux.emit_named_text_section func_name '@'

(* Output a processor register *)

let emit_gpr = emit_int

(* Output a pseudo-register *)

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

(* 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}(30)`
  | Stack s ->
      let ofs = slot_offset env s (register_class r) in
      `{emit_int ofs}(1)`
  | _ -> Misc.fatal_error "Emit.emit_stack"

(* Split a 32-bit integer constants in two 16-bit halves *)

let low_high_u n = (n land 0xFFFF, n asr 16)
  (* unsigned low half, for use with "ori" *)

let native_low_high_u n =
  (Nativeint.(to_int (logand n 0xFFFFn)),
   Nativeint.(to_int (shift_right n 16)))
  (* unsigned low half, for use with "ori" *)

let low_high_s n =
  let lo = ((n + 0x8000) land 0xFFFF) - 0x8000 in
  (lo, (n - lo) asr 16)
  (* signed low half, for use with "addi" *)

let native_low_high_s n =
  let lo = Nativeint.(sub (logand (add n 0x8000n) 0xFFFFn) 0x8000n) in
  (Nativeint.to_int lo,
   Nativeint.(to_int (shift_right (sub n lo) 16)))
  (* signed low half, for use with "addi" *)

let is_immediate n =
  n <= 32767 && n >= -32768

let is_native_immediate n =
  n <= 32767n && n >= -32768n

(* Record TOC entries *)

type tocentry =
  | TocSym of string
  | TocLabel of int
  | TocInt of nativeint
  | TocFloat of int64

let tocref_entries : (tocentry, label) Hashtbl.t = Hashtbl.create 64

let emit_tocentry = function
  | TocSym s -> emit_symbol s
  | TocInt i -> emit_nativeint i
  | TocFloat f -> emit_printf "0x%Lx # %.12g" f (Int64.float_of_bits f)
  | TocLabel lbl -> emit_label lbl

let label_for_tocref entry =
  try
    Hashtbl.find tocref_entries entry
  with Not_found ->
    let lbl = new_label() in
    Hashtbl.add tocref_entries entry lbl;
    lbl

let emit_toctable () =
  Hashtbl.iter
    (fun entry lbl ->
      `{emit_label lbl}:	.quad	{emit_tocentry entry}\n`)
    tocref_entries

(* Emit a load from a TOC entry.

   The [dest] should not be r0, since [dest] is used as the index register for a
   ld instruction, but r0 reads as zero when used as an index register.
*)

let emit_tocload emit_dest dest entry =
  let lbl = label_for_tocref entry in
  `	addis	{emit_dest dest}, 2, {emit_label lbl}@toc@ha\n`;
  `	ld	{emit_dest dest}, {emit_label lbl}@toc@l({emit_dest dest}) # {emit_tocentry entry}\n`

(* Output a load or store operation *)

let load_mnemonic = function
  | Byte_unsigned -> "lbz"
  | Byte_signed -> "lbz"
  | Sixteen_unsigned -> "lhz"
  | Sixteen_signed -> "lha"
  | Thirtytwo_unsigned -> "lwz"
  | Thirtytwo_signed -> "lwa"
  | Word_int | Word_val | Sixtyfour -> "ld"
  | Single -> "lfs"
  | Double -> "lfd"

let store_mnemonic = function
  | Byte_unsigned | Byte_signed -> "stb"
  | Sixteen_unsigned | Sixteen_signed -> "sth"
  | Thirtytwo_unsigned | Thirtytwo_signed -> "stw"
  | Word_int | Word_val | Sixtyfour -> "std"
  | Single -> "stfs"
  | Double -> "stfd"

let store_needs_lwsync chunk assignment =
  assignment && (chunk = Word_int || chunk = Word_val)

let valid_offset instr ofs =
  ofs land 3 = 0 || (instr <> "ld" && instr <> "std" && instr <> "lwa")

let emit_load_store instr addressing_mode addr n arg =
  match addressing_mode with
  | Ibased(s, d) ->
      emit_tocload emit_gpr 11 (TocSym s);
      let (lo, hi) = low_high_s d in
      if hi <> 0 then
        `	addis	11, 11, {emit_int hi}\n`;
      if valid_offset instr lo then
        `	{emit_string instr}	{emit_reg arg}, {emit_int lo}(11)\n`
      else begin
        `	li	0, {emit_int lo}\n`;
        `	{emit_string instr}x	{emit_reg arg}, 11, 0\n`
      end
  | Iindexed ofs ->
      if is_immediate ofs && valid_offset instr ofs then
        `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
      else begin
        let (lo, hi) = low_high_u ofs in
        `	addis	0, 0, {emit_int hi}\n`;
        if lo <> 0 then
          `	ori	0, 0, {emit_int lo}\n`;
        `	{emit_string instr}x	{emit_reg arg}, {emit_reg addr.(n)}, 0\n`
      end
  | Iindexed2 ->
      `	{emit_string instr}x	{emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n`

(* After a comparison, extract the result as 0 or 1 *)

let emit_extract_crbit bitnum negated res =
  `	mfcr	0\n`;
  `	rlwinm	{emit_reg res}, 0, {emit_int(bitnum+1)}, 31, 31\n`;
  if negated then
    `	xori	{emit_reg res}, {emit_reg res}, 1\n`

let emit_set_comp cmp res =
  let bitnum =
    match cmp with
      Ceq | Cne -> 2
    | Cgt | Cle -> 1
    | Clt | Cge -> 0
  and negated =
    match cmp with
    | Cne | Cle | Cge -> true
    | Ceq | Clt | Cgt -> false
  in
    emit_extract_crbit bitnum negated res

let emit_float_comp cmp arg =
  `	fcmpu	0, {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`;
  (* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
  let bitnum =
    match cmp with
    | CFeq | CFneq -> 2
    | CFle | CFnle -> `	cror	3, 0, 2\n`; 3 (* lt or eq *)
    | CFgt | CFngt -> 1
    | CFge | CFnge -> `	cror	3, 1, 2\n`; 3 (* gt or eq *)
    | CFlt | CFnlt -> 0
  and negated =
    match cmp with
    | CFneq | CFngt | CFnge | CFnlt | CFnle -> true
    | CFeq | CFgt | CFge | CFlt | CFle -> false
  in
    (bitnum, negated)

(* Free the stack frame *)

let emit_free_frame env =
  let n = frame_size env in
  if n > 0 then
    `	addi	1, 1, {emit_int n}\n`

(* Emit a "bl" instruction to a given symbol *)

let emit_call s =
  `	bl	{emit_symbol s}\n`

(* Add a nop after a "bl" call for ELF64 *)

let emit_call_nop () =
  `	nop	\n`

(* Reload the TOC register r2 from the value saved on the stack *)

let emit_reload_toc env =
  `	ld	2, {emit_int (toc_save_offset env)}(1)\n`

(* Adjust stack_offset and emit corresponding CFI directive *)

let adjust_stack_offset env delta =
  env.stack_offset <- env.stack_offset + delta;
  cfi_adjust_cfa_offset delta

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

(* Names for conditional branches after comparisons *)

let branch_for_comparison = function
    Ceq -> "beq" | Cne -> "bne"
  | Cle -> "ble" | Cgt -> "bgt"
  | Cge -> "bge" | Clt -> "blt"

let name_for_int_comparison = function
    Isigned cmp -> ("cmpd", branch_for_comparison cmp)
  | Iunsigned cmp -> ("cmpld", branch_for_comparison cmp)

(* Names for various instructions *)

let name_for_intop = function
    Iadd  -> "add"
  | Imul  -> "mulld"
  | Imulh -> "mulhd"
  | Idiv  -> "divd"
  | Iand  -> "and"
  | Ior   -> "or"
  | Ixor  -> "xor"
  | Ilsl  -> "sld"
  | Ilsr  -> "srd"
  | Iasr  -> "srad"
  | _ -> Misc.fatal_error "Emit.Intop"

let name_for_intop_imm = function
    Iadd -> "addi"
  | Imul -> "mulli"
  | Iand -> "andi."
  | Ior  -> "ori"
  | Ixor -> "xori"
  | Ilsl -> "sldi"
  | Ilsr -> "srdi"
  | Iasr -> "sradi"
  | _ -> Misc.fatal_error "Emit.Intop_imm"

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

let name_for_floatop2 = function
    Iaddf -> "fadd"
  | Isubf -> "fsub"
  | Imulf -> "fmul"
  | Idivf -> "fdiv"
  | _ -> Misc.fatal_error "Emit.Iopf2"

let name_for_specific = function
    Imultaddf -> "fmadd"
  | Imultsubf -> "fmsub"
  | _ -> Misc.fatal_error "Emit.Ispecific"

(* Relaxation of branches that exceed the span of a relative branch. *)

module BR = Branch_relaxation.Make (struct
  type distance = int

  module Cond_branch = struct
    type t = Branch

    let all = [Branch]

    let max_displacement = function
      (* 14-bit signed offset in words. *)
      | Branch -> 8192

    let classify_instr = function
      | Lop (Ialloc _)
      | Lop (Ipoll _)
      | Lop (Iintop Icheckbound)
      | Lop (Iintop_imm (Icheckbound, _))
      (* The various "far" variants in [specific_operation] don't need to
         return [Some] here, since their code sequences never contain any
         conditional branches that might need relaxing. *)
      | Lcondbranch _
      | Lcondbranch3 _ -> Some Branch
      | _ -> None
  end

  let offset_pc_at_branch = 1

  let prologue_size f =
    if f.fun_frame_required then 4 else 0

  let tocload_size = 2

  let load_store_size instr = function
    | Ibased(_s, d) ->
      let (lo, hi) = low_high_s d in
      tocload_size +
      (if hi <> 0 then 1 else 0) +
      (if valid_offset instr lo then 1 else 2)
    | Iindexed ofs ->
      if is_immediate ofs && valid_offset instr ofs then 1 else begin
        let (lo, _hi) = low_high_u ofs in
        if lo <> 0 then 3 else 2
      end
    | Iindexed2 -> 1

  let instr_size f = function
    | Lend -> 0
    | Lprologue -> prologue_size f
    | Lop(Imove | Ispill | Ireload) -> 1
    | Lop(Iconst_int n) ->
      if is_native_immediate n then 1
      else if (let (_lo, hi) = native_low_high_s n in
               hi >= -0x8000 && hi <= 0x7FFF) then 2
      else if (let (_lo, hi) = native_low_high_u n in
               hi >= -0x8000 && hi <= 0x7FFF) then 2
      else tocload_size
    | Lop(Iconst_float _) -> tocload_size
    | Lop(Iconst_symbol _) -> tocload_size
    | Lop(Icall_ind) -> 4
    | Lop(Icall_imm _) -> 3
    | Lop(Itailcall_ind) -> 6
    | Lop(Itailcall_imm { func; _ }) ->
        if func = f.fun_name
        then 1
        else 6 + tocload_size
    | Lop(Iextcall { alloc; stack_ofs; _}) ->
        if stack_ofs > 0 then tocload_size + 4
        else if alloc then tocload_size + 2
        else 5
    | Lop(Istackoffset _) -> 1
    | Lop(Iload {memory_chunk; addressing_mode; is_atomic }) ->
      let loadinstr = load_mnemonic memory_chunk in
      (if is_atomic then 4 else 0) +
      (if memory_chunk = Byte_signed then 1 else 0) +
      load_store_size loadinstr addressing_mode
    | Lop(Istore(chunk, addr, assignment)) ->
      let storeinstr = store_mnemonic chunk in
        (if chunk = Single then 1 else 0) +
        (if store_needs_lwsync chunk assignment then 1 else 0) +
        load_store_size storeinstr addr
    | Lop(Ialloc _) -> 5
    | Lop(Ispecific(Ialloc_far _)) -> 6
    | Lop(Ipoll { return_label = Some(_) }) -> 5
    | Lop(Ipoll { return_label = None }) -> 3
    | Lop(Ispecific(Ipoll_far { return_label = Some(_) } )) -> 5
    | Lop(Ispecific(Ipoll_far { return_label = None } )) -> 4
    | Lop(Iintop Imod) -> 3
    | Lop(Iintop(Icomp _)) -> 4
    | Lop(Iintop(Icheckbound)) -> 2
    | Lop(Ispecific(Icheckbound_far)) -> 3
    | Lop(Icompf _) -> 5
    | Lop(Iintop _) -> 1
    | Lop(Iintop_imm(Icomp _, _)) -> 4
    | Lop(Iintop_imm(Icheckbound, _)) -> 2
    | Lop(Ispecific(Icheckbound_imm_far _)) -> 3
    | Lop(Iintop_imm _) -> 1
    | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1
    | Lop(Ifloatofint) -> 3
    | Lop(Iintoffloat) -> 3
    | Lop(Iopaque) -> 0
    | Lop(Ispecific _) -> 1
    | Lop(Idls_get) -> 1
    | Lop(Ireturn_addr) -> 1
    | Lreloadretaddr -> 2
    | Lreturn -> 2
    | Llabel _ -> 0
    | Lbranch _ -> 1
    | Lcondbranch (Ifloattest(CFle | CFnle  | CFge | CFnge), _) -> 3
    | Lcondbranch _ -> 2
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
      1 + (if lbl0 = None then 0 else 1)
        + (if lbl1 = None then 0 else 1)
        + (if lbl2 = None then 0 else 1)
    | Lswitch _ -> 7 + tocload_size
    | Lentertrap -> 1
    | Ladjust_trap_depth _ -> 0
    | Lpushtrap _ -> 4 + tocload_size
    | Lpoptrap -> 2
    | Lraise (Lambda.Raise_regular | Lambda.Raise_reraise) -> 2
    | Lraise Lambda.Raise_notrace -> 5

  let relax_allocation ~num_bytes:bytes ~dbginfo =
    Lop (Ispecific (Ialloc_far { bytes; dbginfo }))

  let relax_poll ~return_label =
    Lop (Ispecific (Ipoll_far { return_label }))

  let relax_intop_checkbound () =
    Lop (Ispecific (Icheckbound_far))

  let relax_intop_imm_checkbound ~bound =
    Lop (Ispecific (Icheckbound_imm_far bound))

  (* [classify_addr], above, never identifies these instructions as needing
     relaxing.  As such, these functions should never be called. *)
  let relax_specific_op _ = assert false
end)

(* Assembly code for inlined allocation *)

let emit_alloc env i bytes dbginfo far =
  if env.call_gc_label = 0 then env.call_gc_label <- new_label ();
  let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
  `	ld	0, {emit_int offset}(30)\n`;
  `	addi	31, 31, {emit_int(-bytes)}\n`;
  `	cmpld	31, 0\n`;
  if not far then begin
    `	bltl-	{emit_label env.call_gc_label}\n`;
    record_frame env i.live (Dbg_alloc dbginfo);
    `	addi	{emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
  end else begin
    let lbl = new_label() in
    `	bge+	{emit_label lbl}\n`;
    `	bl	{emit_label env.call_gc_label}\n`;
    record_frame env i.live (Dbg_alloc dbginfo);
    `{emit_label lbl}:	addi	{emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
  end

let emit_poll env i return_label far =
  if env.call_gc_label = 0 then env.call_gc_label <- new_label ();
  let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
  `	ld	0, {emit_int offset}(30)\n`;
  `	cmpld	31, 0\n`;
  if not far then begin
    begin match return_label with
    | None ->
    begin
      `	bltl-	{emit_label env.call_gc_label}\n`;
      record_frame env i.live (Dbg_alloc [])
    end
    | Some return_label ->
      begin
        `	bltl-	{emit_label env.call_gc_label}\n`;
        record_frame env i.live (Dbg_alloc []);
        `	b	{emit_label return_label}\n`
      end
    end;
  end else begin
    let lbl = new_label () in
    `	bge+	{emit_label lbl}\n`;
    `	bl	{emit_label env.call_gc_label}\n`;
    record_frame env i.live (Dbg_alloc []);
    `{emit_label lbl}:	\n`;
    match return_label with
    | None ->   ()
    | Some return_label -> `	b	{emit_label return_label}\n`
  end

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}:`; emit_call_nop()

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";
    emit_call_nop()

(* 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
      if n > 0 then begin
        `	addi	1, 1, {emit_int(-n)}\n`;
        cfi_adjust_cfa_offset n
      end;
      if env.f.fun_frame_required then begin
        let ra = retaddr_offset env in
        `	mflr	0\n`;
        `	std	0, {emit_int ra}(1)\n`;
        cfi_offset ~reg: 65 (* LR *) ~offset: (ra - n);
        `	std	2, {emit_int(toc_save_offset env)}(1)\n`
      end
    | 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 _} ->
                `	mr	{emit_reg dst}, {emit_reg src}\n`
            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
                `	fmr	{emit_reg dst}, {emit_reg src}\n`
            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
                `	std	{emit_reg src}, {emit_stack env dst}\n`
            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
                `	stfd	{emit_reg src}, {emit_stack env dst}\n`
            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                `	ld	{emit_reg dst}, {emit_stack env src}\n`
            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
                `	lfd	{emit_reg dst}, {emit_stack env src}\n`
            | (_, _) ->
                Misc.fatal_error "Emit: Imove"
        end
    | Lop(Iconst_int n) ->
        if is_native_immediate n then
          `	li	{emit_reg i.res.(0)}, {emit_nativeint n}\n`
        else begin
        (* Try a signed decomposition first, because the sequence
           addis/addi is eligible for instruction fusion. *)
        let (lo, hi) = native_low_high_s n in
        if hi >= -0x8000 && hi <= 0x7FFF then begin
          `	addis	{emit_reg i.res.(0)}, 0, {emit_int hi}\n`;
          if lo <> 0 then
          `	addi	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n`
        end else begin
        (* Now try an unsigned decomposition *)
        let (lo, hi) = native_low_high_u n in
        if hi >= -0x8000 && hi <= 0x7FFF then begin
          `	addis	{emit_reg i.res.(0)}, 0, {emit_int hi}\n`;
          if lo <> 0 then
          `	ori	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n`
        end else begin
          emit_tocload emit_reg i.res.(0) (TocInt n)
        end end end
    | Lop(Iconst_float f) ->
        let entry = TocFloat f in
        let lbl = label_for_tocref entry in
        `	addis	11, 2, {emit_label lbl}@toc@ha\n`;
        `	lfd	{emit_reg i.res.(0)}, {emit_label lbl}@toc@l(11) # {emit_tocentry entry}\n`
    | Lop(Iconst_symbol s) ->
        emit_tocload emit_reg i.res.(0) (TocSym s)
    | Lop(Icall_ind) ->
        `	mtctr	{emit_reg i.arg.(0)}\n`;
        `	mr	12, {emit_reg i.arg.(0)}\n`;  (* addr of fn in r12 *)
        `	bctrl\n`;
        record_frame env i.live (Dbg_other i.dbg);
        emit_reload_toc env
    | Lop(Icall_imm { func; }) ->
        (* For PPC64, we cannot just emit a "bl s; nop" sequence, because
           of the following scenario:
              - current function f1 calls f2 that has the same TOC
              - f2 tailcalls f3 that has a different TOC
           Because f1 and f2 have the same TOC, the linker inserted no
           code in f1 to save and restore r2 around the call to f2.
           Because f2 tailcalls f3, r2 will not be restored to f2's TOC
           when f3 returns.  So, we're back into f1, with the wrong TOC in r2.
           We have two options:
             1- Turn the call into an indirect call, like we do for
                Itailcall_imm.  Cost: 6 instructions.
             2- Follow the "bl" with an instruction to restore r2
                explicitly.  If the called function has a different TOC,
                this instruction is redundant with those inserted
                by the linker, but this is harmless.
                Cost: 3 instructions if same TOC, 7 if different TOC.
           Let's try option 2. *)
        emit_call func;
        record_frame env i.live (Dbg_other i.dbg);
        `	nop\n`;
        emit_reload_toc env
    | Lop(Itailcall_ind) ->
        `	mtctr	{emit_reg i.arg.(0)}\n`;
        `	mr	12, {emit_reg i.arg.(0)}\n`;   (* addr of fn in r12 *)
        if env.f.fun_frame_required then begin
          `	ld	11, {emit_int(retaddr_offset env)}(1)\n`;
          `	mtlr	11\n`
        end;
        emit_free_frame env;
        `	bctr\n`
    | Lop(Itailcall_imm { func; }) ->
        if func = env.f.fun_name then
          `	b	{emit_label env.f.fun_tailrec_entry_point_label}\n`
        else begin
          emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *)
          `	mtctr	12\n`;
          if env.f.fun_frame_required then begin
            `	ld	11, {emit_int(retaddr_offset env)}(1)\n`;
            `	mtlr	11\n`
          end;
          emit_free_frame env;
          `	bctr\n`
        end
    | Lop(Iextcall { func; alloc; stack_ofs }) ->
        if stack_ofs > 0 then begin
          emit_tocload emit_gpr 25 (TocSym func);
         `	li	24, {emit_int stack_ofs}\n`;
             (* size in bytes of stack area containing the arguments *)
          emit_call "caml_c_call_stack_args";
          record_frame env i.live (Dbg_other i.dbg);
          `	nop\n`
        end else if alloc then begin
          emit_tocload emit_gpr 25 (TocSym func);
          emit_call "caml_c_call";
          record_frame env i.live (Dbg_other i.dbg);
          `	nop\n`
        end else begin
          (* Save OCaml stack pointer in a callee-save register *)
          `	mr	28, 1\n`;
          (* Switch to C stack *)
          let offset = Domainstate.(idx_of_field Domain_c_stack) * 8 in
          `	ld	1, {emit_int offset}(30)\n`;
          emit_call func;
          emit_call_nop();
          (* Switch back to OCaml stack *)
          `	mr	1, 28\n`
        end
    | Lop(Istackoffset n) ->
        `	addi	1, 1, {emit_int (-n)}\n`;
        adjust_stack_offset env n
    | Lop(Iload { memory_chunk; addressing_mode; is_atomic }) ->
        let loadinstr = load_mnemonic memory_chunk in
        if is_atomic then
          `	sync\n`;
        emit_load_store loadinstr addressing_mode i.arg 0 i.res.(0);
        if is_atomic then begin
          `	cmpw	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`;
          `	bne-	$+4\n`;
          `	isync\n`
        end;
        if memory_chunk = Byte_signed then
          `	extsb	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Istore(Single, addr, _assignment)) ->
        let tmp = phys_reg 100 (* FPR 0 *) in
        `	frsp	{emit_reg tmp}, {emit_reg i.arg.(0)}\n`;
        emit_load_store "stfs" addr i.arg 1 tmp
    | Lop(Istore(chunk, addr, assignment)) ->
        let storeinstr = store_mnemonic chunk in
        (* Non-initializing stores need a memory barrier to follow the
           Multicore OCaml memory model.  Stores of size other than
           Word_int and Word_val do not follow the memory model and therefore
           do not need a barrier *)
        if store_needs_lwsync chunk assignment then
          `	lwsync\n`;
        emit_load_store storeinstr addr i.arg 1 i.arg.(0)
    | Lop(Ialloc { bytes; dbginfo }) ->
        emit_alloc env i bytes dbginfo false
    | Lop(Ispecific(Ialloc_far { bytes; dbginfo })) ->
        emit_alloc env i bytes dbginfo true
    | Lop(Ipoll { return_label }) ->
        emit_poll env i return_label false
    | Lop(Ispecific(Ipoll_far { return_label })) ->
        emit_poll env i return_label true
    | Lop(Iintop Isub) ->               (* subfc has swapped arguments *)
        `	subfc	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
    | Lop(Iintop Imod) ->
        `	divd	0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	mulld	0, 0, {emit_reg i.arg.(1)}\n`;
        `	subfc	{emit_reg i.res.(0)}, 0, {emit_reg i.arg.(0)}\n`
    | Lop(Iintop(Icomp cmp)) ->
        begin match cmp with
          Isigned c ->
            `	cmpd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            emit_set_comp c i.res.(0)
        | Iunsigned c ->
            `	cmpld	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            emit_set_comp c i.res.(0)
        end
    | Lop(Icompf cmp) ->
        let (bitnum, negated) = emit_float_comp cmp i.arg in
        emit_extract_crbit bitnum negated i.res.(0)
    | Lop(Iintop (Icheckbound)) ->
        let lbl = bound_error_label env i.dbg in
        `	cmpld	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	ble-	{emit_label lbl}\n`
    | Lop(Ispecific (Icheckbound_far)) ->
        let lbl_err = bound_error_label env i.dbg in
        let lbl_next = new_label() in
        `	cmpld	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	bgt+	{emit_label lbl_next}\n`;
        `	b	{emit_label lbl_err}\n`;
        `{emit_label lbl_next}:\n`
    | Lop(Iintop op) ->
        let instr = name_for_intop op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Iintop_imm(Isub, n)) ->
        `	addi	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        begin match cmp with
          Isigned c ->
            `	cmpdi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
            emit_set_comp c i.res.(0)
        | Iunsigned c ->
            `	cmpldi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
            emit_set_comp c i.res.(0)
        end
    | Lop(Iintop_imm(Icheckbound, n)) ->
        let lbl = bound_error_label env i.dbg in
        `	cmpldi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        `	ble-	{emit_label lbl}\n`
    | Lop(Ispecific(Icheckbound_imm_far n)) ->
        let lbl_err = bound_error_label env i.dbg in
        let lbl_next = new_label() in
        `	cmpldi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        `	bgt+	{emit_label lbl_next}\n`;
        `	b	{emit_label lbl_err}\n`;
        `{emit_label lbl_next}:\n`
    | Lop(Iintop_imm(op, n)) ->
        let instr = name_for_intop_imm op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
    | 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) ->
        let instr = name_for_floatop2 op in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Ifloatofint) ->
        (* Can use protected zone (288 bytes below r1 *)
        `	std	{emit_reg i.arg.(0)}, -16(1)\n`;
        `	lfd	{emit_reg i.res.(0)}, -16(1)\n`;
        `	fcfid	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintoffloat) ->
        (* Can use protected zone (288 bytes below r1 *)
        `	fctidz	0, {emit_reg i.arg.(0)}\n`;
        `	stfd	0, -16(1)\n`;
        `	ld	{emit_reg i.res.(0)}, -16(1)\n`
    | Lop(Iopaque) ->
        assert (i.arg.(0).loc = i.res.(0).loc)
    | Lop(Ispecific sop) ->
        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)}, {emit_reg i.arg.(2)}\n`
    | Lop (Idls_get) ->
        let offset = Domainstate.(idx_of_field Domain_dls_root) * 8 in
        `	ld	{emit_reg i.res.(0)}, {emit_int offset}(30)\n`
    | Lop (Ireturn_addr) ->
        if env.f.fun_frame_required then
        `	ld	{emit_reg i.res.(0)}, {emit_int(retaddr_offset env)}(1)\n`
        else
        `	mflr	{emit_reg i.res.(0)}\n`
    | Lreloadretaddr ->
        `	ld	11, {emit_int(retaddr_offset env)}(1)\n`;
        `	mtlr	11\n`
    | Lreturn ->
        emit_free_frame env;
        `	blr\n`
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        `	b	{emit_label lbl}\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            `	cmpdi	{emit_reg i.arg.(0)}, 0\n`;
            `	bne	{emit_label lbl}\n`
        | Ifalsetest ->
            `	cmpdi	{emit_reg i.arg.(0)}, 0\n`;
            `	beq	{emit_label lbl}\n`
        | Iinttest cmp ->
            let (comp, branch) = name_for_int_comparison cmp in
            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	{emit_string branch}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            let (comp, branch) = name_for_int_comparison cmp in
            `	{emit_string comp}i	{emit_reg i.arg.(0)}, {emit_int n}\n`;
            `	{emit_string branch}	{emit_label lbl}\n`
        | Ifloattest cmp -> begin
            let bitnum, negated = emit_float_comp cmp i.arg in
            if negated
            then `	bf	{emit_int bitnum}, {emit_label lbl}\n`
            else `	bt	{emit_int bitnum}, {emit_label lbl}\n`
          end
        | Ioddtest ->
            `	andi.	0, {emit_reg i.arg.(0)}, 1\n`;
            `	bne	{emit_label lbl}\n`
        | Ieventest ->
            `	andi.	0, {emit_reg i.arg.(0)}, 1\n`;
            `	beq	{emit_label lbl}\n`
        end
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
        `	cmpdi	{emit_reg i.arg.(0)}, 1\n`;
        begin match lbl0 with
          None -> ()
        | Some lbl -> `	blt	{emit_label lbl}\n`
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> `	beq	{emit_label lbl}\n`
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> `	bgt	{emit_label lbl}\n`
        end
    | Lswitch jumptbl ->
        let lbl = new_label() in
        let jumptables_lbl = match env.jumptables_lbl with
            | None ->
              env.jumptables_lbl <- Some lbl;
              assert (List.length env.jumptables = 0);
              lbl
            | Some l -> l in
        let start = List.length env.jumptables in
        let (start_lo, start_hi) = low_high_s start in
        emit_tocload emit_gpr 11 (TocLabel jumptables_lbl);
        `	addi	12, {emit_reg i.arg.(0)}, {emit_int start_lo}\n`;
        if start_hi <> 0 then
          `	addis	12, 12, {emit_int start_hi}\n`;
        `	sldi	12, 12, 2\n`;
        `	lwax	0, 11, 12\n`;
        `	add	0, 11, 0\n`;
        `	mtctr	0\n`;
        `	bctr\n`;
        env.jumptables <- List.rev_append (Array.to_list jumptbl) env.jumptables
    | Lentertrap ->
        emit_reload_toc env
    | Ladjust_trap_depth { delta_traps } ->
        adjust_stack_offset env (trap_size * delta_traps)
    | Lpushtrap { lbl_handler; } ->
        `	addi	1, 1, {emit_int (-trap_size)}\n`;
        adjust_stack_offset env trap_size;
        `	std	29, {emit_int reserved_stack_space}(1)\n`;
        emit_tocload emit_gpr 29 (TocLabel lbl_handler);
        `	std	29, {emit_int (reserved_stack_space + 8)}(1)\n`;
        `	addi	29, 1, {emit_int reserved_stack_space}\n`
    | Lpoptrap ->
        `	ld	29, {emit_int reserved_stack_space}(1)\n`;
        `	addi	1, 1, {emit_int trap_size}\n`;
        adjust_stack_offset env (-trap_size)
    | 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_call_nop()
        | Lambda.Raise_reraise ->
            emit_call "caml_reraise_exn";
            record_frame env Reg.Set.empty (Dbg_raise i.dbg);
            emit_call_nop()
        | Lambda.Raise_notrace ->
            `	ld	0, 8(29)\n`;
            `	addi	1, 29, {emit_int (trap_size - reserved_stack_space)}\n`;
            `	mtctr	0\n`;
            `	ld	29, {emit_int (reserved_stack_space - trap_size)}(1)\n`;
            `	bctr\n`
        end

(* Emit a sequence of instructions *)

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

(* On this target, the possible "out of line" code blocks are:
   - a single "call GC" point, which comes immediately after the
     function's body;
   - zero, one or several "call bound error" point, which comes just after.
*)

let max_out_of_line_code_offset fundecl =
  let rec num_checkbounds count instr =
    match instr.desc with
    | Lend -> count
    | Lop (Iintop Icheckbound)
    | Lop (Iintop_imm (Icheckbound, _)) ->
        num_checkbounds (count + 1) instr.next
    (* The following two should never be seen, since this function is run
       before branch relaxation. *)
    | Lop (Ispecific Icheckbound_far)
    | Lop (Ispecific (Icheckbound_imm_far _)) -> assert false
    | _ -> num_checkbounds count instr.next in
  let num_chk = num_checkbounds 0 fundecl.fun_body in
  (* This is what the end of the function looks like:
        - offset 0: call GC point  (5 insn)
        - offset 5: first (or only if not !Clflags.debug) call bound error
                    (2 insns)
        - offsets 7, 9, .. : second, third, ..., call bound error
                    (2 insns each) *)
  if num_chk = 0 then 0
  else if !Clflags.debug then 5 + (num_chk - 1) * 2
  else 5

(* Emission of a function declaration *)

let fundecl fundecl =
  let env = mk_env fundecl in
  emit_named_text_section fundecl.fun_name;
  `	.align	2\n`;
  (* 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
    (* The return address is saved in a register not used for param passing *)
    (* The size is passed in a register normally not used for param passing *)
    `{emit_label overflow}:	mflr	28\n`;
    `	li	27, {emit_int (Config.stack_threshold + max_frame_size / 8)}\n`;
    emit_call "caml_call_realloc_stack";
    emit_call_nop ();
    `	mtlr	28\n`;
    `	b	{emit_label ret}\n`;
    handle_overflow := Some(overflow, ret)
  end;
  (* Function entry point *)
  `	.globl	{emit_symbol fundecl.fun_name}\n`;
  emit_type_directive fundecl.fun_name "@function";
  `{emit_symbol fundecl.fun_name}:\n`;
  `0:	addis	2, 12, (.TOC. - 0b)@ha\n`;
  `	addi	2, 2, (.TOC. - 0b)@l\n`;
  `	.localentry {emit_symbol fundecl.fun_name}, . - 0b\n`;
  emit_debug_info fundecl.fun_dbg;
  cfi_startproc();
  (* Dynamic stack checking *)
  begin match !handle_overflow with
  | None -> ()
  | Some(overflow, ret) ->
      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
      `	ld	11, {emit_int offset}(30)\n`;
      `	addi	11, 11, {emit_int f}\n`;
      `	cmpld	1, 11\n`;
      `	ble-	{emit_label overflow}\n`;
      `{emit_label ret}:\n`
  end;
  BR.relax fundecl
           ~max_out_of_line_code_offset: (max_out_of_line_code_offset fundecl);
  emit_all env fundecl.fun_body;
  (* Emit the glue code to call the GC *)
  if env.call_gc_label > 0 then begin
    `{emit_label env.call_gc_label}:\n`;
    `	std	2, 24(1)\n`;
             (* save our TOC, will be restored by caml_call_gc *)
    emit_tocload emit_gpr 12 (TocSym "caml_call_gc");
    `	mtctr	12\n`;
    `	bctr\n`
  end;
  (* Emit the glue code to handle bound errors *)
  emit_call_bound_errors env;
  cfi_endproc();
  emit_size_directive fundecl.fun_name;
  (* Emit the numeric literals *)
  if env.float_literals <> [] then begin
    emit_string rodata_space;
    `	.align	3\n`;
    List.iter
      (fun { fl; lbl } ->
        `{emit_label lbl}:`;
        emit_float64_split_directive ".long" fl)
      env.float_literals
  end;
  (* Emit the jump tables *)
  match env.jumptables, env.jumptables_lbl with
  | _ :: _, None | [], Some _ -> assert false (* Sanity check *)
  | [], None -> ()
  | _ :: _, Some j ->
    emit_string rodata_space;
    `	.align	2\n`;
    `{emit_label j}:`;
    List.iter
      (fun  lbl ->
         `	.long	{emit_label lbl} - {emit_label j}\n`)
      (List.rev env.jumptables)

(* 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 ->
      `	.align	{emit_int (Misc.log2 n)}\n`

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

(* Beginning / end of an assembly file *)

let begin_assembly() =
  reset_debug_info();
  `	.file	\"\"\n`;  (* PR#7037 *)
  `	.abiversion 2\n`;
  Hashtbl.clear tocref_entries;
  (* Emit the beginning of the segments *)
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  emit_string data_space;
  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;
  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_space because it contains relocations *)
  `	.align  3\n`;   (* #7887 *)
  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 -> `	.balign	{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 the TOC entries *)
  emit_string toc_space;
  emit_toctable();
  Hashtbl.clear tocref_entries;
  emit_nonexecstack_note ()