emit.mlp

#2 "asmcomp/arm64/emit.mlp"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
(*                 Benedikt Meurer, University of Siegen                  *)
(*                                                                        *)
(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*   Copyright 2012 Benedikt Meurer.                                      *)
(*                                                                        *)
(*   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 ARM assembly code, 64-bit mode *)

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

(* Tradeoff between code size and code speed *)

let fastcode_flag = ref true

(* Names for special regs *)

let reg_trap_ptr = phys_reg 23
let reg_alloc_ptr = phys_reg 24
let reg_alloc_limit = phys_reg 25
let reg_tmp1 = phys_reg 26
let reg_x15 = phys_reg 15

(* Output a label *)

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

(* Symbols *)

let emit_symbol s =
  Emitaux.emit_symbol '$' s

(* Output a pseudo-register *)

let emit_reg = function
    {loc = Reg r} -> emit_string (register_name r)
  | _ -> fatal_error "Emit.emit_reg"

(* Likewise, but with the 32-bit name of the register *)

let int_reg_name_w =
  [| "w0";  "w1";  "w2";  "w3";  "w4";  "w5";  "w6";  "w7";
     "w8";  "w9";  "w10"; "w11"; "w12"; "w13"; "w14"; "w15";
     "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25";
     "w26"; "w27"; "w28"; "w16"; "w17" |]

let emit_wreg = function
    {loc = Reg r} -> emit_string int_reg_name_w.(r)
  | _ -> fatal_error "Emit.emit_wreg"

(* Layout of the stack frame *)

let stack_offset = ref 0

let frame_size () =
  let sz =
    !stack_offset +
    8 * num_stack_slots.(0) +
    8 * num_stack_slots.(1) +
    (if !contains_calls then 8 else 0)
  in Misc.align sz 16

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

(* Output a stack reference *)

let emit_stack r =
  match r.loc with
  | Stack s ->
      let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
  | _ -> fatal_error "Emit.emit_stack"

(* Output an addressing mode *)

let emit_symbol_offset s ofs =
  emit_symbol s;
  if ofs > 0 then `+{emit_int ofs}`
  else if ofs < 0 then `-{emit_int (-ofs)}`
  else ()

let emit_addressing addr r =
  match addr with
  | Iindexed ofs ->
      `[{emit_reg r}, #{emit_int ofs}]`
  | Ibased(s, ofs) ->
      assert (not !Clflags.dlcode);  (* see selection.ml *)
      `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]`

(* Record live pointers at call points *)

let record_frame_label ?label live raise_ dbg =
  let lbl =
    match label with
    | None -> new_label()
    | Some label -> 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 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())
    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
  lbl

let record_frame ?label live raise_ dbg =
  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`

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

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

let call_gc_sites = ref ([] : gc_call list)

let emit_call_gc gc =
  `{emit_label gc.gc_lbl}:	bl	{emit_symbol "caml_call_gc"}\n`;
  `{emit_label gc.gc_frame_lbl}:	b	{emit_label gc.gc_return_lbl}\n`

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

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

let bound_error_sites = ref ([] : bound_error_call list)

let bound_error_label ?label dbg =
  if !Clflags.debug || !bound_error_sites = [] then begin
    let lbl_bound_error = new_label() in
    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
    bound_error_sites :=
      { bd_lbl = lbl_bound_error;
        bd_frame_lbl = lbl_frame } :: !bound_error_sites;
    lbl_bound_error
  end else begin
    let bd = List.hd !bound_error_sites in bd.bd_lbl
  end

let emit_call_bound_error bd =
  `{emit_label bd.bd_lbl}:	bl	{emit_symbol "caml_ml_array_bound_error"}\n`;
  `{emit_label bd.bd_frame_lbl}:\n`

(* Names of various instructions *)

let name_for_comparison = function
  | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
  | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
  | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
  | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"

let name_for_int_operation = function
  | Iadd -> "add"
  | Isub -> "sub"
  | Imul -> "mul"
  | Idiv -> "sdiv"
  | Iand -> "and"
  | Ior  -> "orr"
  | Ixor -> "eor"
  | Ilsl -> "lsl"
  | Ilsr -> "lsr"
  | Iasr -> "asr"
  | _ -> assert false

(* Load an integer constant into a register *)

let emit_intconst dst n =
  let rec emit_pos first shift =
    if shift < 0 then begin
      if first then `	mov	{emit_reg dst}, xzr\n`
    end else begin
      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
      if s = 0n then emit_pos first (shift - 16) else begin
        if first then
          `	movz	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`
        else
           `	movk	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
        emit_pos false (shift - 16)
      end
    end
  and emit_neg first shift =
    if shift < 0 then begin
      if first then `	movn	{emit_reg dst}, #0\n`
    end else begin
      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
      if s = 0xFFFFn then emit_neg first (shift - 16) else begin
        if first then
          `	movn	{emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n`
        else
           `	movk	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
        emit_neg false (shift - 16)
      end
    end
  in
    if n < 0n then emit_neg true 48 else emit_pos true 48

let num_instructions_for_intconst n =
  let num_instructions = ref 0 in
  let rec count_pos first shift =
    if shift < 0 then begin
      if first then incr num_instructions
    end else begin
      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
      if s = 0n then count_pos first (shift - 16) else begin
        incr num_instructions;
        count_pos false (shift - 16)
      end
    end
  and count_neg first shift =
    if shift < 0 then begin
      if first then incr num_instructions
    end else begin
      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
      if s = 0xFFFFn then count_neg first (shift - 16) else begin
        incr num_instructions;
        count_neg false (shift - 16)
      end
    end
  in
  if n < 0n then count_neg true 48 else count_pos true 48;
  !num_instructions

(* Recognize float constants appropriate for FMOV dst, #fpimm instruction:
   "a normalized binary floating point encoding with 1 sign bit, 4
    bits of fraction and a 3-bit exponent" *)

let is_immediate_float bits =
  let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in
  let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in
  exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant

(* Adjust sp (up or down) by the given byte amount *)

let emit_stack_adjustment n =
  let instr = if n < 0 then "sub" else "add" in
  let m = abs n in
  assert (m < 0x1_000_000);
  let ml = m land 0xFFF and mh = m land 0xFFF_000 in
  if mh <> 0 then `	{emit_string instr}	sp, sp, #{emit_int mh}\n`;
  if ml <> 0 then `	{emit_string instr}	sp, sp, #{emit_int ml}\n`;
  if n <> 0 then cfi_adjust_cfa_offset (-n)

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

let output_epilogue f =
  let n = frame_size() in
  if !contains_calls then
    `	ldr	x30, [sp, #{emit_int (n-8)}]\n`;
  if n > 0 then
    emit_stack_adjustment n;
  f();
  (* reset CFA back because function body may continue *)
  if n > 0 then cfi_adjust_cfa_offset n

(* Name of current function *)
let function_name = ref ""
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
(* Pending floating-point literals *)
let float_literals = ref ([] : (int64 * label) list)

(* Label a floating-point literal *)
let float_literal f =
  try
    List.assoc f !float_literals
  with Not_found ->
    let lbl = new_label() in
    float_literals := (f, lbl) :: !float_literals;
    lbl

(* Emit all pending literals *)
let emit_literals() =
  if !float_literals <> [] then begin
    `	.align	3\n`;
    List.iter
      (fun (f, lbl) ->
        `{emit_label lbl}:`; emit_float64_directive ".quad" f)
      !float_literals;
    float_literals := []
  end

(* Emit code to load the address of a symbol *)

let emit_load_symbol_addr dst s =
  if not !Clflags.dlcode then begin
    `	adrp	{emit_reg dst}, {emit_symbol s}\n`;
    `	add	{emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n`
  end else begin
    `	adrp	{emit_reg dst}, :got:{emit_symbol s}\n`;
    `	ldr	{emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n`
  end

(* The following functions are used for calculating the sizes of the
   call GC and bounds check points emitted out-of-line from the function
   body.  See branch_relaxation.mli. *)

let num_call_gc_and_check_bound_points instr =
  let rec loop instr ((call_gc, check_bound) as totals) =
    match instr.desc with
    | Lend -> totals
    | Lop (Ialloc _) when !fastcode_flag ->
      loop instr.next (call_gc + 1, check_bound)
    | Lop (Iintop Icheckbound _)
    | Lop (Iintop_imm (Icheckbound _, _))
    | Lop (Ispecific (Ishiftcheckbound _)) ->
      let check_bound =
        (* When not in debug mode, there is at most one check-bound point. *)
        if not !Clflags.debug then 1
        else check_bound + 1
      in
      loop instr.next (call_gc, check_bound)
    (* The following four should never be seen, since this function is run
       before branch relaxation. *)
    | Lop (Ispecific (Ifar_alloc _))
    | Lop (Ispecific Ifar_intop_checkbound _)
    | Lop (Ispecific (Ifar_intop_imm_checkbound _))
    | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false
    | _ -> loop instr.next totals
  in
  loop instr (0, 0)

let max_out_of_line_code_offset ~num_call_gc ~num_check_bound =
  if num_call_gc < 1 && num_check_bound < 1 then 0
  else begin
    let size_of_call_gc = 2 in
    let size_of_check_bound = 1 in
    let size_of_last_thing =
      (* Call-GC points come before check-bound points. *)
      if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc
    in
    let total_size =
      size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound
    in
    let max_offset = total_size - size_of_last_thing in
    assert (max_offset >= 0);
    max_offset
  end

module BR = Branch_relaxation.Make (struct
  (* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we
     assume we will never exceed this.  It would seem to be most likely to
     occur for branches between functions; in this case, the linker should be
     able to insert veneers anyway.  (See section 4.6.7 of the document
     "ELF for the ARM 64-bit architecture (AArch64)".) *)

  type distance = int

  module Cond_branch = struct
    type t = TB | CB | Bcc

    let all = [TB; CB; Bcc]

    (* AArch64 instructions are 32 bits wide, so [distance] in this module
       means units of 32-bit words. *)
    let max_displacement = function
      | TB -> 32 * 1024 / 4  (* +/- 32Kb *)
      | CB | Bcc -> 1 * 1024 * 1024 / 4  (* +/- 1Mb *)

    let classify_instr = function
      | Lop (Ialloc _)
      | Lop (Iintop Icheckbound _)
      | Lop (Iintop_imm (Icheckbound _, _))
      | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc
      (* 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 (Itruetest, _)
      | Lcondbranch (Ifalsetest, _) -> Some CB
      | Lcondbranch (Iinttest _, _)
      | Lcondbranch (Iinttest_imm _, _)
      | Lcondbranch (Ifloattest _, _) -> Some Bcc
      | Lcondbranch (Ioddtest, _)
      | Lcondbranch (Ieventest, _) -> Some TB
      | Lcondbranch3 _ -> Some Bcc
      | _ -> None
  end

  let offset_pc_at_branch = 0

  let prologue_size () =
    (if frame_size () > 0 then 2 else 0)
      + (if !contains_calls then 1 else 0)

  let epilogue_size () =
    if !contains_calls then 3 else 2

  let instr_size = function
    | Lend -> 0
    | Lprologue -> prologue_size ()
    | Lop (Imove | Ispill | Ireload) -> 1
    | Lop (Iconst_int n) ->
      num_instructions_for_intconst n
    | Lop (Iconst_float _) -> 2
    | Lop (Iconst_symbol _) -> 2
    | Lop (Icall_ind _) -> 1
    | Lop (Icall_imm _) -> 1
    | Lop (Itailcall_ind _) -> epilogue_size ()
    | Lop (Itailcall_imm { func; _ }) ->
      if func = !function_name then 1 else epilogue_size ()
    | Lop (Iextcall { alloc = false; }) -> 1
    | Lop (Iextcall { alloc = true; }) -> 3
    | Lop (Istackoffset _) -> 2
    | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) ->
      let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in
      based + begin match size with Single -> 2 | _ -> 1 end
    | Lop (Ialloc {bytes = num_bytes}) when !fastcode_flag ->
      if num_bytes <= 0xFFF then 4 else 5
    | Lop (Ispecific (Ifar_alloc {bytes = num_bytes})) when !fastcode_flag ->
      if num_bytes <= 0xFFF then 5 else 6
    | Lop (Ialloc { bytes = num_bytes; _ })
    | Lop (Ispecific (Ifar_alloc { bytes = num_bytes; _ })) ->
      begin match num_bytes with
      | 16 | 24 | 32 -> 1
      | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_bytes)
      end
    | Lop (Iintop (Icomp _)) -> 2
    | Lop (Iintop_imm (Icomp _, _)) -> 2
    | Lop (Iintop (Icheckbound _)) -> 2
    | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3
    | Lop (Iintop_imm (Icheckbound _, _)) -> 2
    | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3
    | Lop (Ispecific (Ishiftcheckbound _)) -> 2
    | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3
    | Lop (Iintop Imod) -> 2
    | Lop (Iintop Imulh) -> 1
    | Lop (Iintop _) -> 1
    | Lop (Iintop_imm _) -> 1
    | Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1
    | Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1
    | Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1
    | Lop (Ispecific (Ishiftarith _)) -> 1
    | Lop (Ispecific (Imuladd | Imulsub)) -> 1
    | Lop (Ispecific (Ibswap 16)) -> 2
    | Lop (Ispecific (Ibswap _)) -> 1
    | Lop (Iname_for_debugger _) -> 0
    | Lreloadretaddr -> 0
    | Lreturn -> epilogue_size ()
    | Llabel _ -> 0
    | Lbranch _ -> 1
    | Lcondbranch (tst, _) ->
      begin match tst with
      | Itruetest -> 1
      | Ifalsetest -> 1
      | Iinttest _ -> 2
      | Iinttest_imm _ -> 2
      | Ifloattest _ -> 2
      | Ioddtest -> 1
      | Ieventest -> 1
      end
    | Lcondbranch3 (lbl0, lbl1, lbl2) ->
      1 + begin match lbl0 with None -> 0 | Some _ -> 1 end
        + begin match lbl1 with None -> 0 | Some _ -> 1 end
        + begin match lbl2 with None -> 0 | Some _ -> 1 end
    | Lswitch jumptbl -> 3 + Array.length jumptbl
    | Lentertrap -> 0
    | Lpushtrap _ -> 4
    | Lpoptrap -> 1
    | Lraise k ->
      begin match k with
      | Cmm.Raise_withtrace -> 1
      | Cmm.Raise_notrace -> 4
      end

  let relax_allocation ~num_bytes ~label_after_call_gc =
    Lop (Ispecific (Ifar_alloc { bytes = num_bytes; label_after_call_gc; }))

  let relax_intop_checkbound ~label_after_error =
    Lop (Ispecific (Ifar_intop_checkbound { label_after_error; }))

  let relax_intop_imm_checkbound ~bound ~label_after_error =
    Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; }))

  let relax_specific_op = function
    | Ishiftcheckbound { shift; label_after_error; } ->
      Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; }))
    | _ -> assert false
end)

(* Output the assembly code for allocation. *)

let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
  let lbl_frame =
    record_frame_label ?label:label_after_call_gc i.live false i.dbg
  in
  if !fastcode_flag then begin
    let lbl_redo = new_label() in
    let lbl_call_gc = new_label() in
    assert (n < 0x1_000_000);
    let nl = n land 0xFFF and nh = n land 0xFFF_000 in
    `{emit_label lbl_redo}:`;
    if nh <> 0 then
      `	sub	{emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int nh}\n`;
    if nl <> 0 then
      `	sub	{emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int nl}\n`;
    `	cmp	{emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`;
    `	add	{emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`;
    if not far then begin
      `	b.lo	{emit_label lbl_call_gc}\n`
    end else begin
      let lbl = new_label () in
      `	b.cs	{emit_label lbl}\n`;
      `	b	{emit_label lbl_call_gc}\n`;
      `{emit_label lbl}:\n`
    end;
    call_gc_sites :=
      { gc_lbl = lbl_call_gc;
        gc_return_lbl = lbl_redo;
        gc_frame_lbl = lbl_frame } :: !call_gc_sites
  end else begin
    begin match n with
    | 16 -> `	bl	{emit_symbol "caml_alloc1"}\n`
    | 24 -> `	bl	{emit_symbol "caml_alloc2"}\n`
    | 32 -> `	bl	{emit_symbol "caml_alloc3"}\n`
    | _  -> emit_intconst reg_x15 (Nativeint.of_int n);
            `	bl	{emit_symbol "caml_allocN"}\n`
    end;
    `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`
  end

(* Emission of the profiling prelude *)

let emit_profile() = ()   (* TODO *)
(*
  match Config.system with
    "linux_eabi" | "linux_eabihf" | "netbsd" ->
      `	push	\{lr}\n`;
      `	{emit_call "__gnu_mcount_nc"}\n`
  | _ -> ()
*)

(* Output the assembly code for an instruction *)

let emit_instr i =
    emit_debug_info i.dbg;
    match i.desc with
    | Lend -> ()
    | Lprologue ->
      if !Clflags.gprofile then emit_profile();
      let n = frame_size() in
      if n > 0 then
        emit_stack_adjustment (-n);
      if !contains_calls then begin
        cfi_offset ~reg:30 (* return address *) ~offset:(-8);
        `	str	x30, [sp, #{emit_int (n-8)}]\n`
      end;
      `{emit_label !tailrec_entry_point}:\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 = Float}, {loc = Reg _} ->
              `	fmov	{emit_reg dst}, {emit_reg src}\n`
          | {loc = Reg _}, {loc = Reg _} ->
              `	mov	{emit_reg dst}, {emit_reg src}\n`
          | {loc = Reg _}, {loc = Stack _} ->
              `	str	{emit_reg src}, {emit_stack dst}\n`
          | {loc = Stack _}, {loc = Reg _} ->
              `	ldr	{emit_reg dst}, {emit_stack src}\n`
          | _ ->
              assert false
        end
    | Lop(Iconst_int n) ->
        emit_intconst i.res.(0) n
    | Lop(Iconst_float f) ->
        if f = 0L then
          `	fmov	{emit_reg i.res.(0)}, xzr\n`
        else if is_immediate_float f then
          `	fmov	{emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n`
        else begin
          let lbl = float_literal f in
          `	adrp	{emit_reg reg_tmp1}, {emit_label lbl}\n`;
          `	ldr	{emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
        end
    | Lop(Iconst_symbol s) ->
        emit_load_symbol_addr i.res.(0) s
    | Lop(Icall_ind { label_after; }) ->
        `	blr	{emit_reg i.arg.(0)}\n`;
        `{record_frame i.live false i.dbg ~label:label_after}\n`
    | Lop(Icall_imm { func; label_after; }) ->
        `	bl	{emit_symbol func}\n`;
        `{record_frame i.live false i.dbg ~label:label_after}\n`
    | Lop(Itailcall_ind { label_after = _; }) ->
        output_epilogue (fun () -> `	br	{emit_reg i.arg.(0)}\n`)
    | Lop(Itailcall_imm { func; label_after = _; }) ->
        if func = !function_name then
          `	b	{emit_label !tailrec_entry_point}\n`
        else
          output_epilogue (fun () -> `	b	{emit_symbol func}\n`)
    | Lop(Iextcall { func; alloc = false; label_after = _; }) ->
        `	bl	{emit_symbol func}\n`
    | Lop(Iextcall { func; alloc = true; label_after; }) ->
        emit_load_symbol_addr reg_x15 func;
        `	bl	{emit_symbol "caml_c_call"}\n`;
        `{record_frame i.live false i.dbg ~label:label_after}\n`
    | Lop(Istackoffset n) ->
        assert (n mod 16 = 0);
        emit_stack_adjustment (-n);
        stack_offset := !stack_offset + n
    | Lop(Iload(size, addr)) ->
        let dst = i.res.(0) in
        let base =
          match addr with
          | Iindexed _ -> i.arg.(0)
          | Ibased(s, ofs) ->
              assert (not !Clflags.dlcode);  (* see selection.ml *)
              `	adrp	{emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
              reg_tmp1 in
        begin match size with
        | Byte_unsigned ->
            `	ldrb	{emit_wreg dst}, {emit_addressing addr base}\n`
        | Byte_signed ->
            `	ldrsb	{emit_reg dst}, {emit_addressing addr base}\n`
        | Sixteen_unsigned ->
            `	ldrh	{emit_wreg dst}, {emit_addressing addr base}\n`
        | Sixteen_signed ->
            `	ldrsh	{emit_reg dst}, {emit_addressing addr base}\n`
        | Thirtytwo_unsigned ->
            `	ldr	{emit_wreg dst}, {emit_addressing addr base}\n`
        | Thirtytwo_signed ->
            `	ldrsw	{emit_reg dst}, {emit_addressing addr base}\n`
        | Single ->
            `	ldr	s7, {emit_addressing addr base}\n`;
            `	fcvt	{emit_reg dst}, s7\n`
        | Word_int | Word_val | Double | Double_u ->
            `	ldr	{emit_reg dst}, {emit_addressing addr base}\n`
        end
    | Lop(Istore(size, addr, _)) ->
        let src = i.arg.(0) in
        let base =
          match addr with
          | Iindexed _ -> i.arg.(1)
          | Ibased(s, ofs) ->
              assert (not !Clflags.dlcode);
              `	adrp	{emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
              reg_tmp1 in
        begin match size with
        | Byte_unsigned | Byte_signed ->
            `	strb	{emit_wreg src}, {emit_addressing addr base}\n`
        | Sixteen_unsigned | Sixteen_signed ->
            `	strh	{emit_wreg src}, {emit_addressing addr base}\n`
        | Thirtytwo_unsigned | Thirtytwo_signed ->
            `	str	{emit_wreg src}, {emit_addressing addr base}\n`
        | Single ->
            `	fcvt	s7, {emit_reg src}\n`;
            `	str	s7, {emit_addressing addr base}\n`;
        | Word_int | Word_val | Double | Double_u ->
            `	str	{emit_reg src}, {emit_addressing addr base}\n`
        end
    | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
        assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc
    | Lop(Ispecific (Ifar_alloc { bytes = n; label_after_call_gc; })) ->
        assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc
    | Lop(Iintop(Icomp cmp)) ->
        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
        `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
    | Lop(Iintop (Icheckbound { label_after_error; })) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	b.ls	{emit_label lbl}\n`
    | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        let lbl2 = new_label () in
        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	b.hi	{emit_label lbl2}\n`;
        `	b	{emit_label lbl}\n`;
        `{emit_label lbl2}:\n`;
    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
        `	b.ls	{emit_label lbl}\n`
    | Lop(Ispecific(
          Ifar_intop_imm_checkbound { bound; label_after_error; })) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        let lbl2 = new_label () in
        `	cmp	{emit_reg i.arg.(0)}, #{emit_int bound}\n`;
        `	b.hi	{emit_label lbl2}\n`;
        `	b	{emit_label lbl}\n`;
        `{emit_label lbl2}:\n`;
    | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
        `	b.cs	{emit_label lbl}\n`
    | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) ->
        let lbl = bound_error_label i.dbg ?label:label_after_error in
        let lbl2 = new_label () in
        `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
        `	b.lo	{emit_label lbl2}\n`;
        `	b	{emit_label lbl}\n`;
        `{emit_label lbl2}:\n`;
    | Lop(Iintop Imod) ->
        `	sdiv	{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	msub	{emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
    | Lop(Iintop Imulh) ->
        `	smulh	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Iintop op) ->
        let instr = name_for_int_operation op in
        `	{emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Iintop_imm(op, n)) ->
        let instr = name_for_int_operation op in
        `	{emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`
    | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) ->
        let instr = (match op with
                     | Ifloatofint      -> "scvtf"
                     | Iintoffloat      -> "fcvtzs"
                     | Iabsf            -> "fabs"
                     | Inegf            -> "fneg"
                     | Ispecific Isqrtf -> "fsqrt"
                     | _                -> assert false) in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
    | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
        let instr = (match op with
                     | Iaddf              -> "fadd"
                     | Isubf              -> "fsub"
                     | Imulf              -> "fmul"
                     | Idivf              -> "fdiv"
                     | Ispecific Inegmulf -> "fnmul"
                     | _                  -> assert false) in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
    | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
        let instr = (match op with
                     | Imuladdf    -> "fmadd"
                     | Inegmuladdf -> "fnmadd"
                     | Imulsubf    -> "fmsub"
                     | Inegmulsubf -> "fnmsub"
                     | _ -> assert false) in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n`
    | Lop(Ispecific(Ishiftarith(op, shift))) ->
        let instr = (match op with
                       Ishiftadd    -> "add"
                     | Ishiftsub    -> "sub") in
        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
        if shift >= 0
        then `, lsl #{emit_int shift}\n`
        else `, asr #{emit_int (-shift)}\n`
    | Lop(Ispecific(Imuladd | Imulsub as op)) ->
        let instr = (match op with
                       Imuladd -> "madd"
                     | Imulsub -> "msub"
                     | _ -> assert false) 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(Ispecific(Ibswap size)) ->
        begin match size with
        | 16 ->
            `	rev16	{emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`;
            `	ubfm	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n`
        | 32 ->
            `	rev	{emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`
        | 64 ->
            `	rev	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
        | _ ->
            assert false
        end
    | Lop (Iname_for_debugger _) -> ()
    | Lreloadretaddr ->
        ()
    | Lreturn ->
        output_epilogue (fun () -> `	ret\n`)
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        `	b	{emit_label lbl}\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
        | Itruetest ->
            `	cbnz	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
        | Ifalsetest ->
            `	cbz	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
        | Iinttest cmp ->
            `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            let comp = name_for_comparison cmp in
            `	b.{emit_string comp}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
            let comp = name_for_comparison cmp in
            `	b.{emit_string comp}	{emit_label lbl}\n`
        | Ifloattest cmp ->
            let comp =
              match cmp with
              | CFeq -> "eq"
              | CFneq -> "ne"
              | CFlt -> "cc"
              | CFnlt -> "cs"
              | CFle -> "ls"
              | CFnle -> "hi"
              | CFgt -> "gt"
              | CFngt -> "le"
              | CFge -> "ge"
              | CFnge -> "lt"
            in
            `	fcmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	b.{emit_string comp}	{emit_label lbl}\n`
        | Ioddtest ->
            `	tbnz	{emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
        | Ieventest ->
            `	tbz	{emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
        end
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
        `	cmp	{emit_reg i.arg.(0)}, #1\n`;
        begin match lbl0 with
          None -> ()
        | Some lbl -> `	b.lt	{emit_label lbl}\n`
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> `	b.eq	{emit_label lbl}\n`
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> `	b.gt	{emit_label lbl}\n`
        end
    | Lswitch jumptbl ->
        let lbltbl = new_label() in
        `	adr	{emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
        `	add	{emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`;
        `	br	{emit_reg reg_tmp1}\n`;
        `{emit_label lbltbl}:`;
        for j = 0 to Array.length jumptbl - 1 do
            `	b	{emit_label jumptbl.(j)}\n`
        done
(* Alternative:
        let lbltbl = new_label() in
        `	adr	{emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
        `	ldr	{emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`;
        `	add	{emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`;
        `	br	{emit_reg reg_tmp1}\n`;
        `{emit_label lbltbl}:\n`;
        for j = 0 to Array.length jumptbl - 1 do
            `	.word	{emit_label jumptbl.(j)} - {emit_label lbltbl}\n`
        done
*)
    | Lentertrap ->
        ()
    | Lpushtrap { lbl_handler; } ->
        `	adr	{emit_reg reg_tmp1}, {emit_label lbl_handler}\n`;
        stack_offset := !stack_offset + 16;
        `	str	{emit_reg reg_trap_ptr}, [sp, -16]!\n`;
        `	str	{emit_reg reg_tmp1}, [sp, #8]\n`;
        cfi_adjust_cfa_offset 16;
        `	mov	{emit_reg reg_trap_ptr}, sp\n`
    | Lpoptrap ->
        `	ldr	{emit_reg reg_trap_ptr}, [sp], 16\n`;
        cfi_adjust_cfa_offset (-16);
        stack_offset := !stack_offset - 16
    | Lraise k ->
        begin match k with
        | Cmm.Raise_withtrace ->
          `	bl	{emit_symbol "caml_raise_exn"}\n`;
          `{record_frame Reg.Set.empty true i.dbg}\n`
        | Cmm.Raise_notrace ->
          `	mov	sp, {emit_reg reg_trap_ptr}\n`;
          `	ldr	{emit_reg reg_tmp1}, [sp, #8]\n`;
          `	ldr	{emit_reg reg_trap_ptr}, [sp], 16\n`;
          `	br	{emit_reg reg_tmp1}\n`
        end

(* Emission of an instruction sequence *)

let rec emit_all i =
  if i.desc = Lend then () else (emit_instr i; emit_all i.next)

(* Emission of a function declaration *)

let fundecl fundecl =
  function_name := fundecl.fun_name;
  fastcode_flag := fundecl.fun_fast;
  tailrec_entry_point := new_label();
  float_literals := [];
  stack_offset := 0;
  call_gc_sites := [];
  bound_error_sites := [];
  `	.text\n`;
  `	.align	3\n`;
  `	.globl	{emit_symbol fundecl.fun_name}\n`;
  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
  `{emit_symbol fundecl.fun_name}:\n`;
  emit_debug_info fundecl.fun_dbg;
  cfi_startproc();
  let num_call_gc, num_check_bound =
    num_call_gc_and_check_bound_points fundecl.fun_body
  in
  let max_out_of_line_code_offset =
    max_out_of_line_code_offset ~num_call_gc
      ~num_check_bound
  in
  BR.relax fundecl.fun_body ~max_out_of_line_code_offset;
  emit_all fundecl.fun_body;
  List.iter emit_call_gc !call_gc_sites;
  List.iter emit_call_bound_error !bound_error_sites;
  assert (List.length !call_gc_sites = num_call_gc);
  assert (List.length !bound_error_sites = num_check_bound);
  cfi_endproc();
  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
  `	.size	{emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`;
  emit_literals()

(* Emission of data *)

let emit_item = function
  | Cglobal_symbol s -> `	.globl	{emit_symbol s}\n`;
  | Cdefine_symbol s ->
    if !Clflags.dlcode then begin
      (* GOT relocations against non-global symbols don't seem to work
         properly: GOT entries are not created for the symbols and the
         relocations evaluate to random other GOT entries.  For the moment
         force all symbols to be global. *)
      `	.globl	{emit_symbol s}\n`;
    end;
    `{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_string_directive "	.ascii  " s
  | Cskip n -> if n > 0 then `	.space	{emit_int n}\n`
  | Calign n -> `	.align	{emit_int(Misc.log2 n)}\n`

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

(* Beginning / end of an assembly file *)

let begin_assembly() =
  reset_debug_info();
  `	.file	\"\"\n`;  (* PR#7037 *)
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  `	.data\n`;
  `	.globl	{emit_symbol lbl_begin}\n`;
  `{emit_symbol lbl_begin}:\n`;
  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
  `	.text\n`;
  `	.globl	{emit_symbol lbl_begin}\n`;
  `{emit_symbol lbl_begin}:\n`

let end_assembly () =
  let lbl_end = Compilenv.make_symbol (Some "code_end") in
  `	.text\n`;
  `	.globl	{emit_symbol lbl_end}\n`;
  `{emit_symbol lbl_end}:\n`;
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  `	.data\n`;
  `	.quad	0\n`;  (* PR#6329 *)
  `	.globl	{emit_symbol lbl_end}\n`;
  `{emit_symbol lbl_end}:\n`;
  `	.long	0\n`;
  let lbl = Compilenv.make_symbol (Some "frametable") in
  `	.globl	{emit_symbol lbl}\n`;
  `{emit_symbol lbl}:\n`;
  emit_frames
    { efa_code_label = (fun lbl ->
                       `	.type	{emit_label lbl}, %function\n`;
                       `	.quad	{emit_label lbl}\n`);
      efa_data_label = (fun lbl ->
                       `	.type	{emit_label lbl}, %object\n`;
                       `	.quad	{emit_label lbl}\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(Misc.log2 n)}\n`);
      efa_label_rel = (fun lbl ofs ->
                           `	.long	{emit_label lbl} - . + {emit_int32 ofs}\n`);
      efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
      efa_string = (fun s -> emit_string_directive "	.asciz	" s) };
  `	.type	{emit_symbol lbl}, %object\n`;
  `	.size	{emit_symbol lbl}, .-{emit_symbol lbl}\n`;
  begin match Config.system with
  | "linux" ->
      (* Mark stack as non-executable *)
      `	.section	.note.GNU-stack,\"\",%progbits\n`
  | _ -> ()
  end