Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/asmcomp/sparc/emit.mlp

771 lines
26 KiB
Plaintext
Raw Blame History

#2 "asmcomp/sparc/emit.mlp"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Emission of Sparc assembly code *)
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 | Val)} -> 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 ?label live =
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;
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 * int64) 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 _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
` mov {emit_reg src}, {emit_reg dst}\n`
| {loc = Reg _; typ = Float}, {loc = Reg _; 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 _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} ->
(* 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`;
let dst2 = i.res.(1) in
begin match dst2 with
| {loc = Reg _; typ = Int} ->
` ld [%sp + 100], {emit_reg dst2}\n`;
| {loc = Stack _; typ = Int} ->
` ld [%sp + 100], %g1\n`;
` st %g1, {emit_stack dst2}\n`;
| _ ->
fatal_error "Emit: Imove Float [| _; _ |]"
end;
` add %sp, 8, %sp\n`
| {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} ->
` st {emit_reg src}, {emit_stack dst}\n`
| {loc = Reg _; typ = Float}, {loc = Stack _} ->
` std {emit_reg src}, {emit_stack dst}\n`
| {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
` ld {emit_stack src}, {emit_reg dst}\n`
| {loc = Stack _; typ = Float}, {loc = Reg _} ->
` 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 f) ->
(* 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, f) :: !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 { label_after; }) ->
`{record_frame i.live ~label:label_after} call {emit_reg i.arg.(0)}\n`;
fill_delay_slot dslot
| Lop(Icall_imm { func; label_after; }) ->
`{record_frame i.live ~label:label_after} call {emit_symbol func}\n`;
fill_delay_slot dslot
| Lop(Itailcall_ind { label_after = _; }) ->
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 { func; label_after = _; }) ->
let n = frame_size() in
if func = !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 func}), %g1\n`;
` jmp %g1 + %lo({emit_symbol func})\n`;
` add %sp, {emit_int n}, %sp\n` (* in delay slot *)
end
| Lop(Iextcall { func; alloc; label_after; }) ->
if alloc then begin
` sethi %hi({emit_symbol func}), %g2\n`;
`{record_frame i.live ~label:label_after} call {emit_symbol "caml_c_call"}\n`;
` or %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *)
end else begin
` call {emit_symbol func}\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 { words = n; label_after_call_gc; }) ->
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 ?label:label_after_call_gc} 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 Imulh) ->
` smul {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`;
` rd %y, {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(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(Imulh, n)) ->
` smul {emit_reg i.arg.(0)}, {emit_int n}, %g1\n`;
` rd %y, {emit_reg i.res.(0)}\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(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 _) ->
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
Imulh | 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 { alloc = false; }) | Lbranch _}}
when is_one_instr i ->
emit_instr i.next (Some i);
emit_all i.next.next
| {next = {desc = Lop(Itailcall_imm { func; _ })}}
when func = !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`
| 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" (Int32.bits_of_float f)
| Cdouble f ->
emit_float64_split_directive ".word" (Int64.bits_of_float f)
| Csymbol_address s ->
` .word {emit_symbol s}\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 := []
Reference in New Issue View Git Blame Copy Permalink