(* 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

(* 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 _ *)

let emit_symbol s =
  emit_string "_"; Emitaux.emit_symbol s

(* Output a label *)

let emit_label lbl =
  emit_string "L"; 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} + 8\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	2\n`

(* Record floating-point constants *)

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

let emit_float_constant (lbl, cst) =
  `	.data\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_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 -> "fbgt"
  | Clt -> "fbl"   | Cge -> "fbge"

(* Output the assembly code for an instruction *)

let function_name = ref ""
let tailrec_entry_point = ref 0

let emit_instr i =
    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} ->
            if rs <> rd then
              `	mov	{emit_reg src}, {emit_reg dst}\n`
        | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
            if rs <> rd then
              `	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 + 96], {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`;
        `	nop\n`
    | Lop(Icall_imm s) ->
        `{record_frame i.live}	call	{emit_symbol s}\n`;
        `	nop\n`
    | 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`;
        if n > 0 then
          `	add	%sp, {emit_int n}, %sp\n`
        else
          `	nop\n`
    | Lop(Itailcall_imm s) ->
        if s = !function_name then begin
          `	b	{emit_label !tailrec_entry_point}\n`;
          `	nop\n`
        end else begin
          let n = frame_size() in
          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`;
          if n > 0 then
            `	add	%sp, {emit_int n}, %sp\n`
          else
            `	nop\n`
        end
    | Lop(Iextcall s) ->
        `	sethi	%hi({emit_symbol s}), %g1\n`;
        `{record_frame i.live}	call	_caml_c_call\n`;
        `	or	%g1, %lo({emit_symbol s}), %g1\n`
    | 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`;
          `{record_frame i.live}	call	_caml_call_gc\n`;
          `	mov	{emit_int n}, %g1\n`;
          `	add	%g6, 4, {emit_reg i.res.(0)}\n`;
          `{emit_label lbl_cont}:`
        end else begin
          `{record_frame i.live}	call	_caml_alloc\n`;
          `	mov	{emit_int n}, %g1\n`;
          `	add	%g6, 4, {emit_reg i.res.(0)}\n`
        end
    | Lop(Imodify) ->
        if !fastcode_flag then begin
          `	ld	[{emit_reg i.arg.(0)} - 4], %g4\n`;
          `	andcc	%g4, 1024, %g0\n`;
          let lbl_continue = new_label() in
          `	bne	{emit_label lbl_continue}\n`;
          `	nop\n`;
          `	call	_caml_fast_modify\n`;
          `	mov	{emit_reg i.arg.(0)}, %g1\n`;
          `{emit_label lbl_continue}:`
        end else begin
          `	call	_caml_modify\n`;
          `	mov	{emit_reg i.arg.(0)}, %g1\n`
        end
    | 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 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 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)) ->
        `	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`
    | Lop(Iintop_imm(Imod, n)) ->
        `	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`
    | 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(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) ->
        `	faddd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Isubf) ->
        `	fsubd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Imulf) ->
        `	fmuld	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Idivf) ->
        `	fdivd	{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"
    | Lreturn ->
        let n = frame_size() in
        if !contains_calls then
          `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`;
        `	retl\n`;
        if n > 0 then
          `	add	%sp, {emit_int n}, %sp\n`
        else
          `	nop\n`
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        `	b	{emit_label lbl}\n`;
        `	nop\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            `	tst	{emit_reg i.arg.(0)}\n`;
            `	bne	{emit_label lbl}\n`;
            `	nop\n`
        | Ifalsetest ->
            `	tst	{emit_reg i.arg.(0)}\n`;
            `	be	{emit_label lbl}\n`;
            `	nop\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`;
            `	nop\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`;
            `	nop\n`
        | Ifloattest cmp ->
            let comp = name_for_float_comparison cmp in
            `	fcmpd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	{emit_string comp}	{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`;
        `	nop\n`;
        `{emit_label lbl_jumptbl}:`;
        for i = 0 to Array.length jumptbl - 1 do
          `	.word	{emit_label jumptbl.(i)}\n`
        done
    | Lpushtrap lbl ->
        stack_offset := !stack_offset + 8;
        `	sub	%sp, 8, %sp\n`;
        `	sethi	%hi({emit_label lbl}), %g4\n`;
        `	or	%g4, %lo({emit_label lbl}), %g4\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
    | Lentertrap ->
        ()
    | Lraise ->
        `	mov	%g5, %sp\n`;
        `	ldd	[%sp + 96], %g4\n`; (* Load %g4 and %g5 *)
        `	jmp	%g4\n`;
        `	add	%sp, 8, %sp\n`

let rec emit_all i =
  match i.desc with Lend -> () | _ -> 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();
  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}:`;
  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 s ->
      `	.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(Misc.log2 n)}\n`

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

(* Beginning / end of an assembly file *)

let begin_assembly() = ()

let end_assembly() =
  `	.data\n`;
  `	.global	_Frametable\n`;
  `_Frametable:\n`;
  List.iter emit_frame !frame_descriptors;
  frame_descriptors := [];
  `	.word	0\n`