724 lines
24 KiB
Plaintext
724 lines
24 KiB
Plaintext
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* Emission of Motorola 68020 assembly code (MIT syntax) *)
|
|
|
|
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
|
|
|
|
let stack_offset = ref 0
|
|
|
|
(* Layout of the stack frame *)
|
|
|
|
let frame_size () = (* includes return address *)
|
|
!stack_offset +
|
|
4 * (num_stack_slots.(0) + num_stack_slots.(1)) +
|
|
8 * num_stack_slots.(2) +
|
|
4 (* return address *)
|
|
|
|
let slot_offset loc cl =
|
|
match loc with
|
|
Incoming n -> frame_size() + n
|
|
| Local n ->
|
|
if cl = 0
|
|
then !stack_offset + n * 4
|
|
else if cl = 1
|
|
then !stack_offset + num_stack_slots.(0) * 4 + n * 4
|
|
else !stack_offset +
|
|
(num_stack_slots.(0) + num_stack_slots.(1)) * 4 + n * 8
|
|
| Outgoing n -> n
|
|
|
|
(* Output a symbol *)
|
|
|
|
let emit_symbol s =
|
|
emit_char '_'; Emitaux.emit_symbol '$' s
|
|
|
|
(* Output a label *)
|
|
|
|
let emit_label lbl =
|
|
emit_char 'L'; emit_int lbl
|
|
|
|
(* Output an align directive *)
|
|
|
|
let emit_align n =
|
|
` .align {emit_int n}\n`
|
|
|
|
(* Output a pseudo-register *)
|
|
|
|
let emit_reg = function
|
|
{ loc = Reg r } ->
|
|
emit_string (register_name r)
|
|
| { loc = Stack s } as r ->
|
|
let ofs = slot_offset s (register_class r) in
|
|
if ofs = 0
|
|
then `a7@`
|
|
else `a7@({emit_int ofs})`
|
|
| { loc = Unknown } ->
|
|
fatal_error "Emit_m68k.emit_reg"
|
|
|
|
(* Check if the given register is an address register *)
|
|
|
|
let is_address_reg = function { loc = Reg _; typ = Addr } -> true | _ -> false
|
|
|
|
(* Check if the given register overlaps (same location) with the given
|
|
array of registers *)
|
|
|
|
let register_overlap reg arr =
|
|
try
|
|
for i = 0 to Array.length arr - 1 do
|
|
if reg.loc = arr.(i).loc then raise Exit
|
|
done;
|
|
false
|
|
with Exit ->
|
|
true
|
|
|
|
(* Output a suffix for a floating-point instruction -- either .x if
|
|
the argument is a register or .d if it's in memory. *)
|
|
|
|
let emit_float_size r =
|
|
match r.loc with
|
|
Reg _ -> `x`
|
|
| _ -> `d`
|
|
|
|
let emit_float_size2 r1 r2 =
|
|
match (r1.loc, r2.loc) with
|
|
(Reg _, Reg _) -> `x`
|
|
| _ -> `d`
|
|
|
|
(* Output an addressing mode *)
|
|
|
|
let emit_displacement d =
|
|
if d <> 0 then `{emit_int d}, `
|
|
|
|
let emit_addressing addr r n =
|
|
match addr with
|
|
Ibased(s, d) ->
|
|
`{emit_symbol s}`;
|
|
if d <> 0 then ` + {emit_int d}`
|
|
| Iindexed d ->
|
|
`{emit_reg r.(n)}@`;
|
|
if d <> 0 then `({emit_int d})`
|
|
| Iindexed2 d ->
|
|
`{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l)`
|
|
| Iscaled(scale, d) ->
|
|
`@({emit_int d}, {emit_reg r.(n)}:l:{emit_int scale})`
|
|
| Iindexed2scaled(scale, d) ->
|
|
`{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l:{emit_int scale})`
|
|
|
|
(* 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 = 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;
|
|
lbl
|
|
|
|
let record_frame live =
|
|
let lbl = record_frame_label live in `{emit_label lbl}:\n`
|
|
|
|
let emit_frame fd =
|
|
` .long {emit_label fd.fd_lbl}\n`;
|
|
` .word {emit_int fd.fd_frame_size}\n`;
|
|
` .word {emit_int (List.length fd.fd_live_offset)}\n`;
|
|
List.iter
|
|
(fun n ->
|
|
` .word {emit_int n}\n`)
|
|
fd.fd_live_offset;
|
|
emit_align 4
|
|
|
|
(* Names for instructions *)
|
|
|
|
let instr_for_intop = function
|
|
Iadd -> "addl"
|
|
| Isub -> "subl"
|
|
| Imul -> "mulsl"
|
|
| Idiv -> "divsl"
|
|
| Iand -> "andl"
|
|
| Ior -> "orl"
|
|
| Ixor -> "eorl"
|
|
| Ilsl -> "lsll"
|
|
| Ilsr -> "lsrl"
|
|
| Iasr -> "asrl"
|
|
| _ -> fatal_error "Emit_m68k: instr_for_intop"
|
|
|
|
let instr_for_floatop = function
|
|
Inegf -> "fneg"
|
|
| Iabsf -> "fabs"
|
|
| Iaddf -> "fadd"
|
|
| Isubf -> "fsub"
|
|
| Imulf -> "fmul"
|
|
| Idivf -> "fdiv"
|
|
| _ -> fatal_error "Emit_m68k: instr_for_floatop"
|
|
|
|
let name_for_cond_branch = function
|
|
Isigned Ceq -> "eq" | Isigned Cne -> "ne"
|
|
| Isigned Cle -> "le" | Isigned Cgt -> "gt"
|
|
| Isigned Clt -> "lt" | Isigned Cge -> "ge"
|
|
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne"
|
|
| Iunsigned Cle -> "ls" | Iunsigned Cgt -> "hi"
|
|
| Iunsigned Clt -> "cs" | Iunsigned Cge -> "cc"
|
|
|
|
let name_for_float_cond_branch cond neg =
|
|
match cond with
|
|
Ceq -> if neg then "ne" else "eq"
|
|
| Cne -> if neg then "eq" else "ne"
|
|
| Cle -> if neg then "ugt" else "ole"
|
|
| Cgt -> if neg then "ule" else "ogt"
|
|
| Clt -> if neg then "uge" else "olt"
|
|
| Cge -> if neg then "ult" else "oge"
|
|
|
|
(* Emit an immediate move in the given data register *)
|
|
|
|
let emit_move_immediate n dreg =
|
|
if n >= -128 && n < 128
|
|
then ` moveq #{emit_int n}, {emit_string dreg}\n`
|
|
else ` movel #{emit_int n}, {emit_string dreg}\n`
|
|
|
|
(* Offset the stack by the given amount of bytes *)
|
|
|
|
let output_stack_offset n =
|
|
if n > 0 && n <= 8 then
|
|
` subql #{emit_int(n)}, a7\n`
|
|
else if n < 0 && n >= -8 then
|
|
` addql #{emit_int(-n)}, a7\n`
|
|
else
|
|
` addw #{emit_int(-n)}, a7\n`
|
|
|
|
(* Deallocate the stack frame before a return or tail call *)
|
|
|
|
let output_epilogue () =
|
|
let n = frame_size() - 4 in
|
|
if n > 0 then output_stack_offset (-n)
|
|
|
|
(* Record the state of the condition codes *)
|
|
|
|
type condition_code = CCundefined | CCreflect of Reg.t
|
|
|
|
let cc_state = ref CCundefined
|
|
|
|
let undef_cc () =
|
|
cc_state := CCundefined
|
|
|
|
let set_cc reg =
|
|
cc_state := CCreflect reg
|
|
|
|
let output_test reg =
|
|
match !cc_state with
|
|
CCreflect r when r.loc = reg.loc -> ()
|
|
| _ ->
|
|
` tstl {emit_reg reg}\n`;
|
|
cc_state := CCreflect reg
|
|
|
|
(* Output the assembly code for an instruction *)
|
|
|
|
(* Name of current function *)
|
|
let function_name = ref ""
|
|
(* Entry point for tail recursive calls *)
|
|
let tailrec_entry_point = ref 0
|
|
(* Label of trap for out-of-range accesses *)
|
|
let range_check_trap = 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
|
|
if src.loc <> dst.loc then begin
|
|
match (src, dst) with
|
|
({typ = Float; loc = Stack ss}, {loc = Stack sd}) ->
|
|
let os = slot_offset ss 2 in
|
|
let od = slot_offset sd 2 in
|
|
` movel ({emit_int os}, a7), ({emit_int od}, a7)\n`;
|
|
` movel ({emit_int (os+4)}, a7), ({emit_int (od+4)}, a7)\n`;
|
|
undef_cc()
|
|
| ({typ = Float}, _) ->
|
|
` fmove{emit_float_size2 src dst} {emit_reg src}, {emit_reg dst}\n`
|
|
| (_, _) ->
|
|
` movel {emit_reg src}, {emit_reg dst}\n`;
|
|
set_cc dst
|
|
end
|
|
| Lop(Iconst_int n) ->
|
|
begin match i.res.(0) with
|
|
{typ = Addr; loc = Reg _} ->
|
|
if n >= -32768 && n < 32768 then
|
|
` movew #{emit_int n}, {emit_reg i.res.(0)}\n`
|
|
else
|
|
` movel #{emit_int n}, {emit_reg i.res.(0)}\n`
|
|
| _ when n = 0 ->
|
|
` clrl {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| {typ = Int; loc = Reg _} when n >= -128 && n < 128 ->
|
|
` moveq #{emit_int n}, {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| _ ->
|
|
` movel #{emit_int n}, {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
end
|
|
| Lop(Iconst_float s) ->
|
|
let f = float_of_string s in
|
|
if f = 0.0 then
|
|
` fmovecr #0x0F, {emit_reg i.res.(0)}\n`
|
|
else if f = 1.0 then
|
|
` fmovecr #0x32, {emit_reg i.res.(0)}\n`
|
|
else
|
|
` fmoved #0r{emit_string s}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Iconst_symbol s) ->
|
|
` lea {emit_symbol s}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Icall_ind) ->
|
|
` jbsr {emit_reg i.arg.(0)}@\n`;
|
|
record_frame i.live;
|
|
undef_cc()
|
|
| Lop(Icall_imm s) ->
|
|
` jbsr {emit_symbol s}\n`;
|
|
record_frame i.live;
|
|
undef_cc()
|
|
| Lop(Itailcall_ind) ->
|
|
output_epilogue();
|
|
` jmp {emit_reg i.arg.(0)}@\n`;
|
|
undef_cc()
|
|
| Lop(Itailcall_imm s) ->
|
|
if s = !function_name then
|
|
` bra {emit_label !tailrec_entry_point}\n`
|
|
else begin
|
|
output_epilogue();
|
|
` jmp {emit_symbol s}\n`
|
|
end;
|
|
undef_cc()
|
|
| Lop(Iextcall(s, alloc)) ->
|
|
if alloc then begin
|
|
` lea {emit_symbol s}, a0\n`;
|
|
` jbsr {emit_symbol "caml_c_call"}\n`;
|
|
record_frame i.live
|
|
end else begin
|
|
` jbsr {emit_symbol s}\n`
|
|
end;
|
|
if Array.length i.res > 0 && i.res.(0).typ = Float then begin
|
|
` movel d1, a7@-\n`;
|
|
` movel d0, a7@-\n`;
|
|
` fmoved a7@+, {emit_reg i.res.(0)}\n`
|
|
end;
|
|
undef_cc()
|
|
| Lop(Istackoffset n) ->
|
|
output_stack_offset n;
|
|
stack_offset := !stack_offset + n;
|
|
undef_cc()
|
|
| Lop(Iload(chunk, addr)) ->
|
|
let dest = i.res.(0) in
|
|
begin match dest.typ with
|
|
Int | Addr ->
|
|
begin match chunk with
|
|
Word ->
|
|
` movel {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
|
| Byte_unsigned when not (register_overlap dest i.arg) ->
|
|
` clrl {emit_reg dest}\n`;
|
|
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
|
| Byte_unsigned ->
|
|
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
|
` andl #0xFF, {emit_reg dest}\n`
|
|
| Byte_signed ->
|
|
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
|
` extbl {emit_reg dest}\n`
|
|
| Sixteen_unsigned when not (register_overlap dest i.arg) ->
|
|
` clrl {emit_reg dest}\n`;
|
|
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
|
| Sixteen_unsigned ->
|
|
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
|
` andl #0xFFFF, {emit_reg dest}\n`
|
|
| Sixteen_signed ->
|
|
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
|
` extl {emit_reg dest}\n`
|
|
end;
|
|
set_cc dest
|
|
| Float ->
|
|
` fmoved {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
|
end
|
|
| Lop(Istore(chunk, addr)) ->
|
|
let src = i.arg.(0) in
|
|
let instr =
|
|
match src.typ with
|
|
Int ->
|
|
begin match chunk with
|
|
Word -> "movel"
|
|
| Byte_unsigned | Byte_signed -> "moveb"
|
|
| Sixteen_unsigned | Sixteen_signed -> "movew"
|
|
end
|
|
| Addr -> "movel"
|
|
| Float -> "fmoved" in
|
|
` {emit_string instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n`;
|
|
undef_cc()
|
|
| Lop(Ialloc n) ->
|
|
if !fastcode_flag then begin
|
|
let lbl_frame = record_frame_label i.live in
|
|
` subl #{emit_int n}, d6\n`;
|
|
` cmpl {emit_symbol "young_limit"}, d6\n`;
|
|
` bcc {emit_label lbl_frame}\n`;
|
|
emit_move_immediate n "d5";
|
|
` jbsr {emit_symbol "caml_call_gc"}\n`;
|
|
`{emit_label lbl_frame}: movel d6, {emit_reg i.res.(0)}\n`;
|
|
` addql #4, {emit_reg i.res.(0)}\n`
|
|
end else begin
|
|
begin match n with
|
|
8 -> ` jbsr {emit_symbol "caml_alloc1"}\n`
|
|
| 12 -> ` jbsr {emit_symbol "caml_alloc2"}\n`
|
|
| 16 -> ` jbsr {emit_symbol "caml_alloc3"}\n`
|
|
| _ -> emit_move_immediate n "d5";
|
|
` jbsr {emit_symbol "caml_alloc"}\n`
|
|
end;
|
|
`{record_frame i.live} movel d6, {emit_reg i.res.(0)}\n`;
|
|
` addql #4, {emit_reg i.res.(0)}\n`
|
|
end;
|
|
undef_cc()
|
|
| Lop(Iintop(Icomp cmp)) ->
|
|
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
|
let b = name_for_cond_branch cmp in
|
|
` s{emit_string b} {emit_reg i.res.(0)}\n`;
|
|
` negb {emit_reg i.res.(0)}\n`;
|
|
` extbl {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
|
` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`;
|
|
let b = name_for_cond_branch cmp in
|
|
` s{emit_string b} {emit_reg i.res.(0)}\n`;
|
|
` negb {emit_reg i.res.(0)}\n`;
|
|
` extbl {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| Lop(Iintop Icheckbound) ->
|
|
if !range_check_trap = 0 then range_check_trap := new_label();
|
|
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
|
` bls {emit_label !range_check_trap}\n`
|
|
| Lop(Iintop_imm(Icheckbound, n)) ->
|
|
if !range_check_trap = 0 then range_check_trap := new_label();
|
|
` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`;
|
|
` bls {emit_label !range_check_trap}\n`
|
|
| Lop(Iintop_imm(Iadd, n)) ->
|
|
let dest = i.res.(0) in
|
|
begin match dest with
|
|
{loc = Reg _} when n > 0 && n <= 8 ->
|
|
` addql #{emit_int n}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
| {loc = Reg _} when n < 0 && n >= -8 ->
|
|
` subql #{emit_int(-n)}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
| _ ->
|
|
` addl #{emit_int n}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
end
|
|
| Lop(Iintop_imm(Isub, n)) ->
|
|
let dest = i.res.(0) in
|
|
begin match dest with
|
|
{loc = Reg _} when n > 0 && n <= 8 ->
|
|
` subql #{emit_int n}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
| {loc = Reg _} when n < 0 && n >= -8 ->
|
|
` addql #{emit_int(-n)}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
| _ ->
|
|
` subl #{emit_int n}, {emit_reg dest}\n`;
|
|
set_cc i.res.(0)
|
|
end
|
|
| Lop(Iintop_imm(Idiv, n)) when n = 1 lsl (Misc.log2 n) ->
|
|
let l = Misc.log2 n in
|
|
let lbl = new_label() in
|
|
output_test i.arg.(0);
|
|
` bge {emit_label lbl}\n`;
|
|
` addl #{emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
|
|
`{emit_label lbl}:`;
|
|
if l <= 8 then
|
|
` asrl #{emit_int l}, {emit_reg i.arg.(0)}\n`
|
|
else begin
|
|
` moveq #{emit_int l}, d5\n`;
|
|
` asrl d0, {emit_reg i.arg.(0)}\n`
|
|
end;
|
|
set_cc i.res.(0)
|
|
| Lop(Iintop Imod) ->
|
|
` movel {emit_reg i.arg.(0)}, d5\n`;
|
|
` divsll {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}:d5\n`;
|
|
undef_cc()
|
|
| Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) ->
|
|
let l = Misc.log2 n in
|
|
let lbl = new_label() in
|
|
` movel {emit_reg i.arg.(0)}, d5\n`;
|
|
` bge {emit_label lbl}\n`;
|
|
` addl #{emit_int(n-1)}, d5\n`;
|
|
`{emit_label lbl}: andl #{emit_int(-n)}, d5\n`;
|
|
` subl d5, {emit_reg i.arg.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| Lop(Iintop_imm(Imod, n)) ->
|
|
` movel {emit_reg i.arg.(0)}, d5\n`;
|
|
` divsll #{emit_int n}, {emit_reg i.res.(0)}:d5\n`;
|
|
undef_cc()
|
|
| Lop(Iintop op) ->
|
|
(* We have i.arg.(0) = i.res.(0) *)
|
|
` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| Lop(Iintop_imm(op, n)) ->
|
|
(* We have i.arg.(0) = i.res.(0) *)
|
|
` {emit_string(instr_for_intop op)} #{emit_int n}, {emit_reg i.res.(0)}\n`;
|
|
set_cc i.res.(0)
|
|
| Lop(Inegf | Iabsf as floatop) ->
|
|
` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
|
|
` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Ifloatofint) ->
|
|
` fmovel {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Iintoffloat) ->
|
|
` fintrz{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, fp0\n`;
|
|
` fmovel fp0, {emit_reg i.res.(0)}\n`;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ilea addr)) ->
|
|
` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Ispecific(Istore_int(n, addr))) ->
|
|
if n = 0 then
|
|
` clrl {emit_addressing addr i.arg 0}\n`
|
|
else
|
|
` movel #{emit_int n}, {emit_addressing addr i.arg 0}\n`;
|
|
undef_cc()
|
|
| Lop(Ispecific(Istore_symbol(s, addr))) ->
|
|
` movel #{emit_symbol s}, {emit_addressing addr i.arg 0}\n`;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ipush)) ->
|
|
(* Push arguments in reverse order *)
|
|
for n = Array.length i.arg - 1 downto 0 do
|
|
let r = i.arg.(n) in
|
|
match r with
|
|
{loc = Reg _; typ = Float} ->
|
|
` fmoved {emit_reg r}, a7@-\n`;
|
|
stack_offset := !stack_offset + 8
|
|
| {loc = Stack sl; typ = Float} ->
|
|
let ofs = slot_offset sl 2 in
|
|
` movel ({emit_int(ofs + 4)}, a7), a7@-\n`;
|
|
` movel ({emit_int(ofs + 4)}, a7), a7@-\n`;
|
|
stack_offset := !stack_offset + 8
|
|
| _ ->
|
|
` movel {emit_reg r}, a7@-\n`;
|
|
stack_offset := !stack_offset + 4
|
|
done;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ipush_int n)) ->
|
|
` movel #{emit_int n}, a7@-\n`;
|
|
stack_offset := !stack_offset + 4;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ipush_symbol s)) ->
|
|
` pea {emit_symbol s}\n`;
|
|
stack_offset := !stack_offset + 4;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ipush_load addr)) ->
|
|
` movel {emit_addressing addr i.arg 0}, a7@-\n`;
|
|
stack_offset := !stack_offset + 4;
|
|
undef_cc()
|
|
| Lop(Ispecific(Ipush_load_float addr)) ->
|
|
` movel {emit_addressing (offset_addressing addr 4) i.arg 0}, a7@-\n`;
|
|
` movel {emit_addressing addr i.arg 0}, a7@-\n`;
|
|
stack_offset := !stack_offset + 8;
|
|
undef_cc()
|
|
| Lreloadretaddr ->
|
|
()
|
|
| Lreturn ->
|
|
output_epilogue();
|
|
` rts\n`;
|
|
undef_cc()
|
|
| Llabel lbl ->
|
|
`{emit_label lbl}:\n`;
|
|
undef_cc()
|
|
| Lbranch lbl ->
|
|
` bra {emit_label lbl}\n`
|
|
| Lcondbranch(tst, lbl) ->
|
|
begin match tst with
|
|
Itruetest ->
|
|
output_test i.arg.(0);
|
|
` bne {emit_label lbl}\n`
|
|
| Ifalsetest ->
|
|
output_test i.arg.(0);
|
|
` beq {emit_label lbl}\n`
|
|
| Iinttest cmp ->
|
|
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
|
let b = name_for_cond_branch cmp in
|
|
` b{emit_string b} {emit_label lbl}\n`
|
|
| Iinttest_imm(cmp, 0) ->
|
|
output_test i.arg.(0);
|
|
let b = name_for_cond_branch cmp in
|
|
` b{emit_string b} {emit_label lbl}\n`
|
|
| Iinttest_imm(cmp, n) ->
|
|
` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`;
|
|
let b = name_for_cond_branch cmp in
|
|
` b{emit_string b} {emit_label lbl}\n`
|
|
| Ifloattest(cmp, neg) ->
|
|
` fcmp{emit_float_size2 i.arg.(0) i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
|
let b = name_for_float_cond_branch cmp neg in
|
|
` fb{emit_string b} {emit_label lbl}\n`
|
|
| Ioddtest ->
|
|
begin match i.arg.(0) with
|
|
{typ = Addr; loc = Reg _} as arg ->
|
|
` movel {emit_reg arg}, d5\n`;
|
|
` btst #0, d5\n`
|
|
| arg ->
|
|
` btst #0, {emit_reg arg}\n`
|
|
end;
|
|
` bne {emit_label lbl}\n`
|
|
| Ieventest ->
|
|
begin match i.arg.(0) with
|
|
{typ = Addr; loc = Reg _} as arg ->
|
|
` movel {emit_reg arg}, d5\n`;
|
|
` btst #0, d5\n`
|
|
| arg ->
|
|
` btst #0, {emit_reg arg}\n`
|
|
end;
|
|
` beq {emit_label lbl}\n`
|
|
end;
|
|
undef_cc()
|
|
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
|
` cmpl #1, {emit_reg i.arg.(0)}\n`;
|
|
begin match lbl0 with
|
|
None -> ()
|
|
| Some lbl -> ` blt {emit_label lbl}\n`
|
|
end;
|
|
begin match lbl1 with
|
|
None -> ()
|
|
| Some lbl -> ` beq {emit_label lbl}\n`
|
|
end;
|
|
begin match lbl2 with
|
|
None -> ()
|
|
| Some lbl -> ` bgt {emit_label lbl}\n`
|
|
end;
|
|
undef_cc()
|
|
| Lswitch jumptbl ->
|
|
let lbl_load = new_label() in
|
|
let lbl_table = new_label() in
|
|
`{emit_label lbl_load}: movew pc@({emit_label lbl_table}-{emit_label lbl_load}-2:b, {emit_reg i.arg.(0)}:l:2), d0\n`;
|
|
` jmp pc@(2, d0:w)\n`;
|
|
`{emit_label lbl_table}:`;
|
|
for i = 0 to Array.length jumptbl - 1 do
|
|
` .word {emit_label jumptbl.(i)} - {emit_label lbl_table}\n`
|
|
done;
|
|
undef_cc()
|
|
| Lsetuptrap lbl ->
|
|
` bsr {emit_label lbl}\n`
|
|
| Lpushtrap ->
|
|
` movel d7, a7@-\n`;
|
|
` movel a7, d7\n`;
|
|
stack_offset := !stack_offset + 8;
|
|
undef_cc()
|
|
| Lpoptrap ->
|
|
` movel a7@+, d7\n`;
|
|
` addql #4, a7\n`;
|
|
stack_offset := !stack_offset - 8;
|
|
undef_cc()
|
|
| Lraise ->
|
|
` movel d7, a7\n`;
|
|
` movel a7@+, d7\n`;
|
|
` rts\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;
|
|
range_check_trap := 0;
|
|
undef_cc();
|
|
` .text\n`;
|
|
` .globl {emit_symbol fundecl.fun_name}\n`;
|
|
`{emit_symbol fundecl.fun_name}:\n`;
|
|
let n = frame_size() - 4 in
|
|
if n > 0 then output_stack_offset n;
|
|
`{emit_label !tailrec_entry_point}:\n`;
|
|
emit_all fundecl.fun_body;
|
|
if !range_check_trap > 0 then
|
|
`{emit_label !range_check_trap}: jbsr {emit_symbol "array_bound_error"}\n`
|
|
|
|
(* Emission of data *)
|
|
|
|
let emit_item = function
|
|
Cdefine_symbol s ->
|
|
` .globl {emit_symbol s}\n`;
|
|
`{emit_symbol s}:\n`
|
|
| Cdefine_label lbl ->
|
|
`{emit_label (10000 + lbl)}:\n`
|
|
| Cint8 n ->
|
|
` .byte {emit_int n}\n`
|
|
| Cint16 n ->
|
|
` .word {emit_int n}\n`
|
|
| Cint n ->
|
|
` .long {emit_int n}\n`
|
|
| Cintlit n ->
|
|
` .long {emit_string n}\n`
|
|
| Cfloat f ->
|
|
` .double 0r{emit_string f}\n`
|
|
| Csymbol_address s ->
|
|
` .long {emit_symbol s}\n`
|
|
| Clabel_address lbl ->
|
|
` .long {emit_label (10000 + lbl)}\n`
|
|
| Cstring s ->
|
|
emit_string_directive " .ascii " s
|
|
| Cskip n ->
|
|
if n > 0 then ` .skip {emit_int n}\n`
|
|
| Calign n ->
|
|
emit_align n
|
|
|
|
let data l =
|
|
` .data\n`;
|
|
List.iter emit_item l
|
|
|
|
(* Beginning / end of an assembly file *)
|
|
|
|
let begin_assembly() =
|
|
let lbl_begin = Compilenv.current_unit_name() ^ "_begin" in
|
|
` .data\n`;
|
|
` .globl {emit_symbol lbl_begin}\n`;
|
|
`{emit_symbol lbl_begin}:\n`
|
|
|
|
let end_assembly() =
|
|
` .data\n`;
|
|
let lbl_end = Compilenv.current_unit_name() ^ "_end" in
|
|
` .globl {emit_symbol lbl_end}\n`;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
` .long 0\n`;
|
|
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
|
` .globl {emit_symbol lbl}\n`;
|
|
`{emit_symbol lbl}:\n`;
|
|
` .long {emit_int (List.length !frame_descriptors)}\n`;
|
|
List.iter emit_frame !frame_descriptors;
|
|
frame_descriptors := []
|