ocaml/asmcomp/emit_sparc.mlp

(***********************************************************************)
(*                                                                     *)
(*                         Caml Special Light                          *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1995 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Emission of Sparc assembly code *)

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

(* Layout of the stack *)
(* Always keep the stack 8-aligned.
   Always leave 96 bytes at the bottom of the stack *)

let stack_offset = ref 0

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

let slot_offset loc class =
  match loc with
    Incoming n -> frame_size() + n + 96
  | Local n ->
      if class = 0
      then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96
      else !stack_offset + n * 8 + 96
  | Outgoing n -> n + 96

(* Return the other register in a register pair *)

let next_in_pair = function
    {loc = Reg r; typ = (Int | Addr)} -> phys_reg (r + 1)
  | {loc = Reg r; typ = Float} -> phys_reg (r + 15)
  | _ -> fatal_error "Emit.next_in_pair"

(* Symbols are prefixed with _ under SunOS but not under Solaris *)

let symbol_prefix =
  match Config.system with
    "sunos" -> "_"
  | "solaris" -> ""
  | _ -> fatal_error "Emit_sparc.symbol_prefix"

let emit_symbol s =
  emit_string symbol_prefix; Emitaux.emit_symbol s

(* Output a label *)

let label_prefix =
  match Config.system with
    "sunos" -> "L"
  | "solaris" -> ".L"
  | _ -> fatal_error "Emit_sparc.label_prefix"

let emit_label lbl =
  emit_string label_prefix; emit_int lbl

(* Output a pseudo-register *)

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

(* 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 a load *)

let emit_load instr addr arg dst =
  match addr with
    Ibased(s, 0) ->
        `	sethi	%hi({emit_symbol s}), %g1\n`;
        `	{emit_string instr}	[%g1 + %lo({emit_symbol s})], {emit_reg dst}\n`
  | Ibased(s, ofs) ->
        `	sethi	%hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
        `	{emit_string instr}	[%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n`
  | Iindexed ofs ->
      if is_immediate ofs then
        `	{emit_string instr}	[{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n`
      else begin
        `	sethi	%hi({emit_int ofs}), %g1\n`;
        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
      end
  | Iindexed2 ofs ->
      if ofs = 0 then
        `	{emit_string instr}	[{emit_reg arg.(0)} + {emit_reg arg.(1)}], {emit_reg dst}\n`
      else if is_immediate ofs then begin
        `	add	{emit_reg arg.(1)}, {emit_int ofs}, %g1\n`;
        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
      end else begin
        `	sethi	%hi({emit_int ofs}), %g1\n`;
        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
        `	add	{emit_reg arg.(1)}, %g1, %g1\n`;
        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
      end

(* Output a store *)

let emit_store instr addr arg src =
  match addr with
    Ibased(s, 0) ->
        `	sethi	%hi({emit_symbol s}), %g1\n`;
        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo({emit_symbol s})]\n`
  | Ibased(s, ofs) ->
        `	sethi	%hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n`
  | Iindexed ofs ->
      if is_immediate ofs then
        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n`
      else begin
        `	sethi	%hi({emit_int ofs}), %g1\n`;
        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
      end
  | Iindexed2 ofs ->
      if ofs = 0 then
        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + {emit_reg arg.(2)}]\n`
      else if is_immediate ofs then begin
        `	add	{emit_reg arg.(2)}, {emit_int ofs}, %g1\n`;
        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
      end else begin
        `	sethi	%hi({emit_int ofs}), %g1\n`;
        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
        `	add	{emit_reg arg.(2)}, %g1, %g1\n`;
        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
      end

(* Record live pointers at call points *)

type frame_descr =
  { fd_lbl: int;                        (* Return address *)
    fd_frame_size: int;                 (* Size of stack frame *)
    fd_live_offset: int list }          (* Offsets/regs of live addresses *)

let frame_descriptors = ref([] : frame_descr list)

let record_frame live =
  let lbl = new_label() in
  let live_offset = ref [] in
  Reg.Set.iter
    (function
        {typ = Addr; loc = Reg r} ->
          live_offset := (-1 - r) :: !live_offset
      | {typ = Addr; loc = Stack s} as reg ->
          live_offset := slot_offset s (register_class reg) :: !live_offset
      | _ -> ())
    live;
  frame_descriptors :=
    { fd_lbl = lbl;
      fd_frame_size = frame_size();
      fd_live_offset = !live_offset } :: !frame_descriptors;
  `{emit_label lbl}:`

let emit_frame fd =
  `	.word	{emit_label fd.fd_lbl}\n`;
  `	.half	{emit_int fd.fd_frame_size}\n`;
  `	.half	{emit_int (List.length fd.fd_live_offset)}\n`;
  List.iter
    (fun n ->
      `	.half	{emit_int n}\n`)
    fd.fd_live_offset;
  `	.align	4\n`

(* Record floating-point constants *)

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

let emit_float_constant (lbl, cst) =
  `	.data\n`;
  `	.align	8\n`;
  `{emit_label lbl}:	.double	0r{emit_string cst}\n`

(* Names of various instructions *)

let name_for_int_operation = function
    Iadd -> "add"
  | Isub -> "sub"
  | Imul -> "smul"
  | Iand -> "and"
  | Ior -> "or"
  | Ixor -> "xor"
  | Ilsl -> "sll"
  | Ilsr -> "srl"
  | Iasr -> "sra"
  | _ -> Misc.fatal_error "Emit.name_for_int_operation"

let name_for_float_operation = function
    Iaddf -> "faddd"
  | Isubf -> "fsubd"
  | Imulf -> "fmuld"
  | Idivf -> "fdivd"
  | _ -> Misc.fatal_error "Emit.name_for_float_operation"

let name_for_int_comparison = function
    Isigned Ceq -> "be"      | Isigned Cne -> "bne"
  | Isigned Cle -> "ble"     | Isigned Cgt -> "bg"
  | Isigned Clt -> "bl"      | Isigned Cge -> "bge"
  | Iunsigned Ceq -> "be"    | Iunsigned Cne -> "bne"
  | Iunsigned Cle -> "bleu"  | Iunsigned Cgt -> "bgu"
  | Iunsigned Clt -> "blu"   | Iunsigned Cge -> "bgeu"

let name_for_float_comparison = function
    Ceq -> "fbe"   | Cne -> "fbne"
  | Cle -> "fble"  | Cgt -> "fbg"
  | Clt -> "fbl"   | Cge -> "fbge"

(* Output the assembly code for an instruction *)

let function_name = ref ""
let tailrec_entry_point = ref 0

let rec emit_instr i dslot =
    match i.desc with
      Lend -> ()
    | Lop(Imove | Ispill | Ireload) ->
        let src = i.arg.(0) and dst = i.res.(0) in
        begin match (src, dst) with
            {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
              `	mov	{emit_reg src}, {emit_reg dst}\n`
          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
              `	fmovd	{emit_reg src}, {emit_reg dst}\n`
          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr)} ->
              (* This happens when calling C functions and passing a float arg
                 in %o0...%o5 *)
              `	sub	%sp, 8, %sp\n`;
              `	std	{emit_reg src}, [%sp + 96]\n`;
              if rd land 1 = 0 then
                `	ldd	[%sp + 96], {emit_reg dst}\n`
              else begin
                `	ld	[%sp + 96], {emit_reg dst}\n`;
                `	ld	[%sp + 100], {emit_reg(next_in_pair dst)}\n`
              end;
              `	add	%sp, 8, %sp\n`
          | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
              `	st	{emit_reg src}, {emit_stack dst}\n`
          | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
              `	std	{emit_reg src}, {emit_stack dst}\n`
          | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
              `	ld	{emit_stack src}, {emit_reg dst}\n`
          | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
              `	ldd	{emit_stack src}, {emit_reg dst}\n`
          | (_, _) ->
              fatal_error "Emit: Imove"
        end
    | Lop(Iconst_int n) ->
        if is_immediate n then
          `	mov	{emit_int n}, {emit_reg i.res.(0)}\n`
        else begin
          `	sethi	%hi({emit_int n}), %g1\n`;
          `	or	%g1, %lo({emit_int n}), {emit_reg i.res.(0)}\n`
        end
    | Lop(Iconst_float s) ->
        let lbl = new_label() in
        float_constants := (lbl, s) :: !float_constants;
        `	sethi	%hi({emit_label lbl}), %g1\n`;
        `	ldd	[%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
    | Lop(Iconst_symbol s) ->
        `	sethi	%hi({emit_symbol s}), %g1\n`;
        `	or	%g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n`
    | Lop(Icall_ind) ->
        `{record_frame i.live}	call	{emit_reg i.arg.(0)}\n`;
        fill_delay_slot dslot
    | Lop(Icall_imm s) ->
        `{record_frame i.live}	call	{emit_symbol s}\n`;
        fill_delay_slot dslot
    | Lop(Itailcall_ind) ->
        let n = frame_size() in
        if !contains_calls then
          `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`;
        `	jmp	{emit_reg i.arg.(0)}\n`;
        `	add	%sp, {emit_int n}, %sp\n` (* in delay slot *)
    | Lop(Itailcall_imm s) ->
        let n = frame_size() in
        if s = !function_name then begin
            `	b	{emit_label !tailrec_entry_point}\n`;
            fill_delay_slot dslot
        end else begin
          if !contains_calls then
            `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`;
          `	sethi	%hi({emit_symbol s}), %g1\n`;
          `	jmp	%g1 + %lo({emit_symbol s})\n`;
          `	add	%sp, {emit_int n}, %sp\n` (* in delay slot *)
        end
    | Lop(Iextcall(s, alloc)) ->
        if alloc then begin
          `	sethi	%hi({emit_symbol s}), %g4\n`;
          `{record_frame i.live}	call	{emit_symbol "caml_c_call"}\n`;
          `	or	%g4, %lo({emit_symbol s}), %g4\n` (* in delay slot *)
        end else begin
          `	call	{emit_symbol s}\n`;
          fill_delay_slot dslot
        end
    | Lop(Istackoffset n) ->
        `	add	%sp, {emit_int (-n)}, %sp\n`;
        stack_offset := !stack_offset + n
    | Lop(Iload(chunk, addr)) ->
        begin match i.res.(0).typ with
          Int | Addr ->
            let loadinstr =
              match chunk with
                Word -> "ld"
              | Byte_unsigned -> "ldub"
              | Byte_signed -> "ldsb"
              | Sixteen_unsigned -> "lduh"
              | Sixteen_signed -> "ldsh" in
            emit_load loadinstr addr i.arg i.res.(0)
        | Float ->
            emit_load "ld" addr i.arg i.res.(0);
            emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair i.res.(0))
        end
    | Lop(Istore(chunk, addr)) ->
        begin match i.arg.(0).typ with
          Int | Addr ->
            let storeinstr =
              match chunk with
                Word -> "st"
              | Byte_unsigned | Byte_signed -> "stb"
              | Sixteen_unsigned | Sixteen_signed -> "sth" in
            emit_store storeinstr addr i.arg i.arg.(0)
        | Float ->
            emit_store "st" addr i.arg i.arg.(0);
            emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair i.arg.(0))
        end
    | Lop(Ialloc n) ->
        if !fastcode_flag then begin
          let lbl_cont = new_label() in
          `	sub	%g6, {emit_int n}, %g6\n`;
          `	cmp	%g6, %g7\n`;
          `	bgeu	{emit_label lbl_cont}\n`;
          `	add	%g6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
          `{record_frame i.live}	call	{emit_symbol "caml_call_gc"}\n`;
          `	mov	{emit_int n}, %g4\n`; (* in delay slot *)
          `	add	%g6, 4, {emit_reg i.res.(0)}\n`;
          `{emit_label lbl_cont}:\n`
        end else begin
          `{record_frame i.live}	call	{emit_symbol "caml_alloc"}\n`;
          `	mov	{emit_int n}, %g4\n`; (* in delay slot *)
          `	add	%g6, 4, {emit_reg i.res.(0)}\n`
        end
    | Lop(Iintop Idiv) ->
        `	sra	{emit_reg i.arg.(0)}, 31, %g1\n`;
        `	wr	%g0, %g1, %y\n`;
        `	nop\n`;
        `	nop\n`;
        `	nop\n`;
        `	sdiv	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop Imod) ->
        `	sra	{emit_reg i.arg.(0)}, 31, %g1\n`;
        `	wr	%g0, %g1, %y\n`;
        `	nop\n`;
        `	nop\n`;
        `	nop\n`;
        `	sdiv	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`;
        `	smul	%g1, {emit_reg i.arg.(1)}, %g1\n`;
        `	sub	{emit_reg i.arg.(0)}, %g1, {emit_reg i.res.(0)}\n`
    | Lop(Iintop(Icomp cmp)) ->
        let comp = name_for_int_comparison cmp in
        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        let lbl = new_label() in
        `	{emit_string comp},a	{emit_label lbl}\n`;
        `	mov	1, {emit_reg i.res.(0)}\n`;
        `	mov	0, {emit_reg i.res.(0)}\n`;
        `{emit_label lbl}:\n`
    | Lop(Iintop Icheckbound) ->
        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
        `	tleu	5\n`            (* 5 = ST_RANGE_CHECK *)
    | Lop(Iintop op) ->
        let instr = name_for_int_operation op in
        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Idiv, n)) ->
        let l = Misc.log2 n in
        if n = 1 lsl l then begin
          let lbl = new_label() in
          `	cmp	{emit_reg i.arg.(0)}, 0\n`;
          `	bge	{emit_label lbl}\n`;
          `	mov	{emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *)
          `	add	%g1, {emit_int (n-1)}, %g1\n`;
          `{emit_label lbl}:\n`;
          `	sra	%g1, {emit_int l}, {emit_reg i.res.(0)}\n`
        end else begin
          `	sra	{emit_reg i.arg.(0)}, 31, %g1\n`;
          `	wr	%g0, %g1, %y\n`;
          `	nop\n`;
          `	nop\n`;
          `	nop\n`;
          `	sdiv	{emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
        end
    | Lop(Iintop_imm(Imod, n)) ->
        let l = Misc.log2 n in
        if n = 1 lsl l then begin
          let lbl = new_label() in
          `	tst	{emit_reg i.arg.(0)}\n`;
          `	bge	{emit_label lbl}\n`;
          `	andcc	{emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *)
          `	be	{emit_label lbl}\n`;
          `	nop\n`;
          `	sub	{emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`;
          `{emit_label lbl}:\n`
        end else begin
          `	sra	{emit_reg i.arg.(0)}, 31, %g1\n`;
          `	wr	%g0, %g1, %y\n`;
          `	nop\n`;
          `	nop\n`;
          `	nop\n`;
          `	sdiv	{emit_reg i.arg.(0)}, {emit_int n}, %g1\n`;
          `	smul	%g1, {emit_int n}, %g1\n`;
          `	sub	{emit_reg i.arg.(0)}, %g1, {emit_reg i.res.(0)}\n`
        end
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        let comp = name_for_int_comparison cmp in
        `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        let lbl = new_label() in
        `	{emit_string comp},a	{emit_label lbl}\n`;
        `	mov	1, {emit_reg i.res.(0)}\n`;
        `	mov	0, {emit_reg i.res.(0)}\n`;
        `{emit_label lbl}:\n`
    | Lop(Iintop_imm(Icheckbound, n)) ->
        `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
        `	tleu	5\n`            (* 5 = ST_RANGE_CHECK *)
    | Lop(Iintop_imm(op, n)) ->
        let instr = name_for_int_operation op in
        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
        let instr = name_for_float_operation op in
        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Ifloatofint) ->
        `	sub	%sp, 4, %sp\n`;
        `	st	{emit_reg i.arg.(0)}, [%sp + 96]\n`;
        `	ld	[%sp + 96], %f30\n`;
        `	add	%sp, 4, %sp\n`;
        `	fitod	%f30, {emit_reg i.res.(0)}\n`
    | Lop(Iintoffloat) ->
        `	fdtoi	{emit_reg i.arg.(0)}, %f30\n`;
        `	sub	%sp, 4, %sp\n`;
        `	st	%f30, [%sp + 96]\n`;
        `	ld	[%sp + 96], {emit_reg i.res.(0)}\n`;
        `	add	%sp, 4, %sp\n`
    | Lop(Ispecific sop) ->
        fatal_error "Emit: specific"
    | Lreloadretaddr ->
        let n = frame_size() in
        `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`
    | Lreturn ->
        let n = frame_size() in
        (* Must and the return address even if this is a leaf routine,
           because it may have been tail-called with a marked retaddr. *)
        `	andn	%o7, 1, %o7\n`;
        `	retl\n`;
        `	add	%sp, {emit_int n}, %sp\n`
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        `	b	{emit_label lbl}\n`;
        fill_delay_slot dslot
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            `	tst	{emit_reg i.arg.(0)}\n`;
            `	bne	{emit_label lbl}\n`
        | Ifalsetest ->
            `	tst	{emit_reg i.arg.(0)}\n`;
            `	be	{emit_label lbl}\n`
        | Iinttest cmp ->
            let comp = name_for_int_comparison cmp in
            `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	{emit_string comp}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            let comp = name_for_int_comparison cmp in
            `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
            `	{emit_string comp}	{emit_label lbl}\n`
        | Ifloattest cmp ->
            let comp = name_for_float_comparison cmp in
            `	fcmpd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	nop\n`;
            `	{emit_string comp}	{emit_label lbl}\n`
        | Ioddtest ->
            `	andcc	{emit_reg i.arg.(0)}, 1, %g0\n`;
            `	bne	{emit_label lbl}\n`
        | Ieventest ->
            `	andcc	{emit_reg i.arg.(0)}, 1, %g0\n`;
            `	be	{emit_label lbl}\n`
        end;
        fill_delay_slot dslot
  | Lcondbranch3(lbl0, lbl1, lbl2) ->
        `	cmp	{emit_reg i.arg.(0)}, 1\n`;
        begin match lbl0 with
          None -> ()
        | Some lbl -> `	bl	{emit_label lbl}\n	nop\n`
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> `	be	{emit_label lbl}\n	nop\n`
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> `	bg	{emit_label lbl}\n	nop\n`
        end
    | Lswitch jumptbl ->
        let lbl_jumptbl = new_label() in
        `	sethi	%hi({emit_label lbl_jumptbl}), %g1\n`;
        `	or	%g1, %lo({emit_label lbl_jumptbl}), %g1\n`;
        `	sll	{emit_reg i.arg.(0)}, 2, %g4\n`;
        `	ld	[%g1 + %g4], %g1\n`;
        `	jmp	%g1\n`;         (* poor scheduling *)
        `	nop\n`;
        `{emit_label lbl_jumptbl}:`;
        for i = 0 to Array.length jumptbl - 1 do
          `	.word	{emit_label jumptbl.(i)}\n`
        done
    | Lsetuptrap lbl ->
        `	call	{emit_label lbl}\n`;
        `	mov     %o7, %g4\n`     (* in delay slot *)
    | Lpushtrap ->
        stack_offset := !stack_offset + 8;
        `	sub	%sp, 8, %sp\n`;
        `	std	%g4, [%sp + 96]\n`; (* Write %g4 and %g5 *)
        `	mov	%sp, %g5\n`
    | Lpoptrap ->
        `	ld	[%sp + 100], %g5\n`;
        `	add	%sp, 8, %sp\n`;
        stack_offset := !stack_offset - 8
    | Lraise ->
        `	mov	%g5, %sp\n`;
        `	ldd	[%sp + 96], %g4\n`; (* Load %g4 and %g5 *)
        `	jmp	%g4 + 8\n`;         (* poor scheduling *)
        `	add	%sp, 8, %sp\n`

and emit_delay_slot = function
    None -> ()
  | Some i -> emit_instr i None

and fill_delay_slot = function
    None -> `	nop\n`
  | Some i -> emit_instr i None

(* Checks if a pseudo-instruction expands to exactly one machine instruction
   that does not branch. *)

let is_one_instr_op = function
    Idiv | Imod | Icomp _ | Icheckbound -> false
  | _ -> true

let is_one_instr i =
  match i.desc with
    Lop op ->
      begin match op with
        Imove | Ispill | Ireload -> i.arg.(0).typ = i.res.(0).typ
      | Iconst_int n -> is_immediate n
      | Istackoffset _ -> true
      | Iload(_, Iindexed n) -> is_immediate n
      | Iload(_, Iindexed2 n) -> n = 0
      | Istore(_, Iindexed n) -> is_immediate n
      | Istore(_, Iindexed2 n) -> n = 0
      | Iintop(op) -> is_one_instr_op op
      | Iintop_imm(op, _) -> is_one_instr_op op
      | Iaddf | Isubf | Imulf | Idivf -> true
      | _ -> false
      end
  | _ -> false

let no_interference res arg =
  try
    for i = 0 to Array.length arg - 1 do
      for j = 0 to Array.length res - 1 do
        if arg.(i).loc = res.(j).loc then raise Exit
      done
    done;
    true
  with Exit ->
    false

(* Emit a sequence of instructions, trying to fill delay slots for branches *)

let rec emit_all i =
  match i with
    {desc = Lend} -> ()
  | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}}
    when is_one_instr i ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | {next = {desc = Lop(Itailcall_imm s)}}
    when s = !function_name & is_one_instr i ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | {next = {desc = Lop(Icall_ind)}}
    when is_one_instr i & no_interference i.res i.next.arg ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | {next = {desc = Lcondbranch(_, _)}}
    when is_one_instr i & no_interference i.res i.next.arg ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | _ ->
      emit_instr i None;
      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();
  stack_offset := 0;
  float_constants := [];
  `	.text\n`;
  `	.align	4\n`;
  `	.global	{emit_symbol fundecl.fun_name}\n`;
  `{emit_symbol fundecl.fun_name}:\n`;
  let n = frame_size() in
  if n > 0 then
    `	sub	%sp, {emit_int n}, %sp\n`;
  if !contains_calls then
    `	st	%o7, [%sp + {emit_int(n - 4 + 96)}]\n`;
  `{emit_label !tailrec_entry_point}:\n`;
  emit_all fundecl.fun_body;
  List.iter emit_float_constant !float_constants

(* Emission of data *)

let emit_item = function
    Cdefine_symbol s ->
      `	.global	{emit_symbol s}\n`;
      `{emit_symbol s}:\n`
  | Cdefine_label lbl ->
      `{emit_label (lbl + 10000)}:\n`
  | Cint8 n ->
      `	.byte	{emit_int n}\n`
  | Cint16 n ->
      `	.half	{emit_int n}\n`
  | Cint n ->
      `	.word	{emit_int n}\n`
  | Cfloat f ->
      `	.double	0r{emit_string f}\n`
  | Csymbol_address s ->
      `	.word	{emit_symbol s}\n`
  | Clabel_address lbl ->
      `	.word	{emit_label (lbl + 10000)}\n`
  | Cstring s ->
      let l = String.length s in
      if l = 0 then ()
      else if l < 80 then
        `	.ascii	{emit_string_literal s}\n`
      else begin
        let i = ref 0 in
        while !i < l do
          let n = min (l - !i) 80 in
          `	.ascii	{emit_string_literal(String.sub s !i n)}\n`;
          i := !i + n
        done
      end
  | Cskip n ->
      if n > 0 then `	.skip	{emit_int n}\n`
  | Calign n ->
      `	.align	{emit_int n}\n`

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

(* Beginning / end of an assembly file *)

let begin_assembly() = ()

let end_assembly() =
  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
  `	.data\n`;
  `	.global	{emit_symbol lbl}\n`;
  `{emit_symbol lbl}:\n`;
  `	.word	{emit_int (List.length !frame_descriptors)}\n`;
  List.iter emit_frame !frame_descriptors;
  frame_descriptors := []