diff options
Diffstat (limited to 'ocaml-binary-annot/asmcomp/sparc/emit.mlp')
| -rw-r--r-- | ocaml-binary-annot/asmcomp/sparc/emit.mlp | 776 |
1 files changed, 776 insertions, 0 deletions
diff --git a/ocaml-binary-annot/asmcomp/sparc/emit.mlp b/ocaml-binary-annot/asmcomp/sparc/emit.mlp new file mode 100644 index 0000000000..f44f813e53 --- /dev/null +++ b/ocaml-binary-annot/asmcomp/sparc/emit.mlp @@ -0,0 +1,776 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Emission of Sparc assembly code *) + +open Location +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Solaris vs. the other ports *) + +let solaris = Config.system = "solaris" + +(* 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 cl = + match loc with + Incoming n -> frame_size() + n + 96 + | Local n -> + if cl = 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 + 16) + | _ -> fatal_error "Emit.next_in_pair" + +(* Symbols are prefixed with _ under SunOS *) + +let symbol_prefix = + if Config.system = "sunos" then "_" else "" + +let emit_symbol s = + if String.length s >= 1 & s.[0] = '.' + then emit_string s + else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end + +let emit_size lbl = + if Config.system = "solaris" then + ` .size {emit_symbol lbl},.-{emit_symbol lbl}\n` + +let rodata () = + if Config.system = "solaris" (* || Config.system = "linux" *) + (* || Config.system = "gnu" *) then + ` .section \".rodata\"\n` + else + ` .data\n` + +(* Check if an integer or native integer is an immediate operand *) + +let is_immediate n = + n <= 4095 && n >= -4096 + +let is_native_immediate n = + n <= Nativeint.of_int 4095 && n >= Nativeint.of_int (-4096) + +(* Output a label *) + +let label_prefix = + if Config.system = "sunos" then "L" else ".L" + +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 + +(* 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 + +(* 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 := ((r lsl 1) + 1) :: !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) = + rodata (); + ` .align 8\n`; + `{emit_label lbl}:`; + emit_float64_split_directive ".word" cst + +(* Emission of the profiling prelude *) +let emit_profile () = + begin match Config.system with + "solaris" -> + let lbl = new_label() in + ` .section \".bss\"\n`; + `{emit_label lbl}: .skip 4\n`; + ` .text\n`; + ` save %sp,-96,%sp\n`; + ` sethi %hi({emit_label lbl}),%o0\n`; + ` call _mcount\n`; + ` or %o0,%lo({emit_label lbl}),%o0\n`; + ` restore\n` + | _ -> () + end + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sll" + | Ilsr -> "srl" + | Iasr -> "sra" + | Imul -> "smul" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" + +let name_for_float_operation = function + Inegf -> if !arch_version = SPARC_V9 then "fnegd" else "fnegs" + | Iabsf -> if !arch_version = SPARC_V9 then "fabsd" else "fabss" + | Iaddf -> "faddd" + | Isubf -> "fsubd" + | Imulf -> "fmuld" + | Idivf -> "fdivd" + | _ -> Misc.fatal_error "Emit.name_for_float_operation" + +let name_for_int_movcc = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gu" + | Iunsigned Clt -> "lu" | Iunsigned Cge -> "geu" + +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 cmp neg = + match cmp with + Ceq -> if neg then "fbne" else "fbe" + | Cne -> if neg then "fbe" else "fbne" + | Cle -> if neg then "fbug" else "fble" + | Cgt -> if neg then "fbule" else "fbg" + | Clt -> if neg then "fbuge" else "fbl" + | Cge -> if neg then "fbul" else "fbge" + +(* Output the assembly code for an instruction *) + +let function_name = ref "" +let tailrec_entry_point = ref 0 +let range_check_trap = 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} -> + if !arch_version = SPARC_V9 then + ` fmovd {emit_reg src}, {emit_reg dst}\n` + else begin + ` fmovs {emit_reg src}, {emit_reg dst}\n`; + ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` + end + | {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`; + ` ld [%sp + 96], {emit_reg dst}\n`; + ` ld [%sp + 100], {emit_reg(next_in_pair dst)}\n`; + ` 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_native_immediate n then + ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` + else begin + ` sethi %hi({emit_nativeint n}), %g1\n`; + ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` + end + | Lop(Iconst_float s) -> + (* On UltraSPARC, the fzero instruction could be used to set a + floating point register pair to zero. *) + 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}), %g2\n`; + `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; + ` or %g2, %lo({emit_symbol s}), %g2\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)) -> + let dest = i.res.(0) in + begin match chunk with + Double_u -> + emit_load "ld" addr i.arg dest; + emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair dest) + | Single -> + emit_load "ld" addr i.arg dest; + ` fstod {emit_reg dest}, {emit_reg dest}\n` + | _ -> + let loadinstr = + match chunk with + Byte_unsigned -> "ldub" + | Byte_signed -> "ldsb" + | Sixteen_unsigned -> "lduh" + | Sixteen_signed -> "ldsh" + | Double -> "ldd" + | _ -> "ld" in + emit_load loadinstr addr i.arg dest + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + begin match chunk with + Double_u -> + emit_store "st" addr i.arg src; + emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair src) + | Single -> + ` fdtos {emit_reg src}, %f30\n`; + emit_store "st" addr i.arg (phys_reg 115) (* %f30 *) + | _ -> + let storeinstr = + match chunk with + | Byte_unsigned | Byte_signed -> "stb" + | Sixteen_unsigned | Sixteen_signed -> "sth" + | Double -> "std" + | _ -> "st" in + emit_store storeinstr addr i.arg src + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_cont = new_label() in + if solaris then begin + ` sub %l6, {emit_int n}, %l6\n`; + ` cmp %l6, %l7\n` + end else begin + ` ld [%l7], %g1\n`; + ` sub %l6, {emit_int n}, %l6\n`; + ` cmp %l6, %g1\n` + end; + ` bgeu {emit_label lbl_cont}\n`; + ` add %l6, 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}, %g2\n`; (* in delay slot *) + ` add %l6, 4, {emit_reg i.res.(0)}\n`; + `{emit_label lbl_cont}:\n` + end else begin + `{record_frame i.live} call {emit_symbol "caml_allocN"}\n`; + ` mov {emit_int n}, %g2\n`; (* in delay slot *) + ` add %l6, 4, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + if !arch_version = SPARC_V9 then begin + let comp = name_for_int_movcc cmp in + ` mov 0, {emit_reg i.res.(0)}\n`; + ` mov{emit_string comp} %icc, 1, {emit_reg i.res.(0)}\n` + end + else begin + let comp = name_for_int_comparison cmp + and 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` + end + | Lop(Iintop Icheckbound) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + if solaris then + ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) + else begin + if !range_check_trap = 0 then range_check_trap := new_label(); + ` bleu {emit_label !range_check_trap}\n`; + ` nop\n` (* delay slot *) + end + | Lop(Iintop Idiv) -> + ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; + ` wr %g1, %y\n`; + ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {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(Ilsl, 1)) -> + (* UltraSPARC has two add units but only one shifter. *) + ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {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 %g1, %y\n`; + ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) + 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` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + if !arch_version = SPARC_V9 then begin + let comp = name_for_int_movcc cmp in + ` mov 0, {emit_reg i.res.(0)}\n`; + ` mov{emit_string comp} %icc, 1, {emit_reg i.res.(0)}\n` + end else begin + let comp = name_for_int_comparison cmp + and 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` + end + | Lop(Iintop_imm(Icheckbound, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + if solaris then + ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) + else begin + if !range_check_trap = 0 then range_check_trap := new_label(); + ` bleu {emit_label !range_check_trap}\n`; + ` nop\n` (* delay slot *) + end + | 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(Inegf | Iabsf as op) -> + let instr = name_for_float_operation op in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; + if !arch_version <> SPARC_V9 then + ` fmovs {emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair 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, 8, %sp\n`; + ` st {emit_reg i.arg.(0)}, [%sp + 96]\n`; + ` ld [%sp + 96], %f30\n`; + ` add %sp, 8, %sp\n`; + ` fitod %f30, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` fdtoi {emit_reg i.arg.(0)}, %f30\n`; + ` sub %sp, 8, %sp\n`; + ` st %f30, [%sp + 96]\n`; + ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; + ` add %sp, 8, %sp\n` + | Lop(Ispecific sop) -> + assert false + | Lreloadretaddr -> + let n = frame_size() in + ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n` + | Lreturn -> + let n = frame_size() in + ` retl\n`; + if n = 0 then + ` nop\n` + else + ` 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, neg) -> + let comp = name_for_float_comparison cmp neg 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, %g2\n`; + ` ld [%g1 + %g2], %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`; + ` sub %sp, 8, %sp\n` (* in delay slot *) + | Lpushtrap -> + stack_offset := !stack_offset + 8; + ` st %o7, [%sp + 96]\n`; + ` st %l5, [%sp + 100]\n`; + ` mov %sp, %l5\n` + | Lpoptrap -> + ` ld [%sp + 100], %l5\n`; + ` add %sp, 8, %sp\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` ld [%l5 + 96], %g1\n`; + ` mov %l5, %sp\n`; + ` ld [%sp + 100], %l5\n`; + ` jmp %g1 + 8\n`; + ` add %sp, 8, %sp\n` + +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 <> Float && i.res.(0).typ <> Float + | Iconst_int n -> is_native_immediate n + | Istackoffset _ -> true + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n + | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n + | Iintop(op) -> is_one_instr_op op + | Iintop_imm(op, _) -> is_one_instr_op op + | Iaddf | Isubf | Imulf | Idivf -> true + | Iabsf | Inegf -> !arch_version = SPARC_V9 + | _ -> 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(); + range_check_trap := 0; + stack_offset := 0; + float_constants := []; + ` .text\n`; + ` .align 4\n`; + ` .global {emit_symbol fundecl.fun_name}\n`; + if Config.system = "solaris" then + ` .type {emit_symbol fundecl.fun_name},#function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.gprofile then emit_profile(); + 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; + if !range_check_trap > 0 then begin + `{emit_label !range_check_trap}:\n`; + ` call {emit_symbol "caml_ml_array_bound_error"}\n`; + ` nop\n` + end; + emit_size fundecl.fun_name; + List.iter emit_float_constant !float_constants + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` .global {emit_symbol s}\n`; + | Cdefine_symbol s -> + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (lbl + 100000)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .half {emit_int n}\n` + | Cint32 n -> + ` .word {emit_nativeint n}\n` + | Cint n -> + ` .word {emit_nativeint n}\n` + | Csingle f -> + emit_float32_directive ".word" f + | Cdouble f -> + emit_float64_split_directive ".word" f + | Csymbol_address s -> + ` .word {emit_symbol s}\n` + | Clabel_address lbl -> + ` .word {emit_label (lbl + 100000)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | 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 lbl_begin = Compilenv.make_symbol (Some "data_begin") in + ` .data\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + ` .text\n`; + ` .global {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + ` .text\n`; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + ` .global {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .word 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + rodata (); + ` .global {emit_symbol lbl}\n`; + if Config.system = "solaris" then + ` .type {emit_symbol lbl},#object\n`; + `{emit_symbol lbl}:\n`; + ` .word {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + emit_size lbl; + frame_descriptors := [] |