677 lines
22 KiB
Plaintext
677 lines
22 KiB
Plaintext
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1998 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 ARM 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
|
|
|
|
(* Output a label *)
|
|
|
|
let emit_label lbl =
|
|
emit_string ".L"; emit_int lbl
|
|
|
|
(* Output a symbol *)
|
|
|
|
let emit_symbol s =
|
|
Emitaux.emit_symbol '$' s
|
|
|
|
(* Output a pseudo-register *)
|
|
|
|
let emit_reg r =
|
|
match r.loc with
|
|
Reg r -> emit_string (register_name r)
|
|
| _ -> fatal_error "Emit_arm.emit_reg"
|
|
|
|
(* Output the next register after the given pseudo-register *)
|
|
|
|
let emit_next_reg r =
|
|
match r.loc with
|
|
Reg r -> emit_string (register_name(r + 1))
|
|
| _ -> fatal_error "Emit_arm.emit_next_reg"
|
|
|
|
(* Layout of the stack frame *)
|
|
|
|
let stack_offset = ref 0
|
|
|
|
let frame_size () =
|
|
!stack_offset +
|
|
4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
|
|
(if !contains_calls then 4 else 0)
|
|
|
|
let slot_offset loc cl =
|
|
match loc with
|
|
Incoming n -> frame_size() + n
|
|
| Local n ->
|
|
if cl = 0
|
|
then !stack_offset + num_stack_slots.(1) * 8 + n * 4
|
|
else !stack_offset + n * 8
|
|
| Outgoing n -> n
|
|
|
|
(* 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_arm.emit_stack"
|
|
|
|
(* Output an addressing mode *)
|
|
|
|
let emit_addressing addr r n =
|
|
match addr with
|
|
Iindexed ofs ->
|
|
`[{emit_reg r.(n)}, #{emit_int ofs}]`
|
|
|
|
(* 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} + 4\n`;
|
|
` .short {emit_int fd.fd_frame_size}\n`;
|
|
` .short {emit_int (List.length fd.fd_live_offset)}\n`;
|
|
List.iter
|
|
(fun n ->
|
|
` .short {emit_int n}\n`)
|
|
fd.fd_live_offset;
|
|
` .align 2\n`
|
|
|
|
(* Names of various instructions *)
|
|
|
|
let name_for_comparison = function
|
|
Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
|
|
| Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
|
|
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
|
|
| Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
|
|
|
|
let name_for_float_comparison cmp neg =
|
|
match cmp with
|
|
Ceq -> if neg then "ne" else "eq"
|
|
| Cne -> if neg then "eq" else "ne"
|
|
| Cle -> if neg then "hi" else "ls"
|
|
| Cge -> if neg then "lt" else "ge"
|
|
| Clt -> if neg then "pl" else "mi"
|
|
| Cgt -> if neg then "le" else "gt"
|
|
|
|
let name_for_int_operation = function
|
|
Iadd -> "add"
|
|
| Isub -> "sub"
|
|
| Imul -> "mul"
|
|
| Iand -> "and"
|
|
| Ior -> "orr"
|
|
| Ixor -> "eor"
|
|
| _ -> assert false
|
|
|
|
let name_for_shift_operation = function
|
|
Ilsl -> "lsl"
|
|
| Ilsr -> "lsr"
|
|
| Iasr -> "asr"
|
|
| _ -> assert false
|
|
|
|
let name_for_shift_int_operation = function
|
|
Ishiftadd -> "add"
|
|
| Ishiftsub -> "sub"
|
|
| Ishiftsubrev -> "rsb"
|
|
|
|
let name_for_float_operation = function
|
|
Inegf -> "mnfd"
|
|
| Iabsf -> "absd"
|
|
| Iaddf -> "adfd"
|
|
| Isubf -> "sufd"
|
|
| Imulf -> "mufd"
|
|
| Idivf -> "dvfd"
|
|
| Ifloatofint -> "fltd"
|
|
| Iintoffloat -> "fixz"
|
|
| _ -> assert false
|
|
|
|
(* Recognize immediate operands *)
|
|
|
|
(* Immediate operands are 8-bit immediate values, zero-extended, and rotated
|
|
right by 0, 2, 4, ... 30 bits.
|
|
We check only with 8-bit values shifted left 0 to 24 bits. *)
|
|
|
|
let rec is_immed n shift =
|
|
shift <= 24 &&
|
|
(Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n
|
|
|| is_immed n (shift + 2))
|
|
|
|
let is_immediate n = is_immed n 0
|
|
|
|
(* General functional to decompose a non-immediate integer constant
|
|
into 8-bit chunks shifted left 0 ... 24 bits *)
|
|
|
|
let decompose_intconst n fn =
|
|
let i = ref n in
|
|
let shift = ref 0 in
|
|
let ninstr = ref 0 in
|
|
while !i <> Nativeint.zero do
|
|
if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then
|
|
shift := !shift + 2
|
|
else begin
|
|
let mask = Nativeint.shift_left (Nativeint.of_int 0xFF) !shift in
|
|
let bits = Nativeint.logand !i mask in
|
|
fn bits;
|
|
shift := !shift + 8;
|
|
i := Nativeint.sub !i bits;
|
|
incr ninstr
|
|
end
|
|
done;
|
|
!ninstr
|
|
|
|
(* Emit a non-immediate integer constant *)
|
|
|
|
let emit_complex_intconst r n =
|
|
let first = ref true in
|
|
decompose_intconst n
|
|
(fun bits ->
|
|
if !first
|
|
then ` mov {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n`
|
|
else ` add {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`;
|
|
first := false)
|
|
|
|
(* Adjust sp (up or down) by the given byte amount *)
|
|
|
|
let emit_stack_adjustment instr n =
|
|
if n <= 0 then 0 else
|
|
decompose_intconst (Nativeint.of_int n)
|
|
(fun bits ->
|
|
` {emit_string instr} sp, sp, #{emit_nativeint bits}\n`)
|
|
|
|
(* Adjust alloc_ptr down by the given byte amount *)
|
|
|
|
let emit_alloc_decrement n =
|
|
decompose_intconst (Nativeint.of_int n)
|
|
(fun bits ->
|
|
` sub alloc_ptr, alloc_ptr, #{emit_nativeint bits}\n`)
|
|
|
|
(* Name of current function *)
|
|
let function_name = ref ""
|
|
(* Entry point for tail recursive calls *)
|
|
let tailrec_entry_point = ref 0
|
|
(* Table of symbols referenced *)
|
|
let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
|
(* Table of floating-point literals *)
|
|
let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
|
(* Total space (in word) occupied by pending literals *)
|
|
let num_literals = ref 0
|
|
(* True if we've at least one pending float literal *)
|
|
let pending_float = ref false
|
|
|
|
(* Label a symbol or float constant *)
|
|
let label_constant tbl s size =
|
|
try
|
|
Hashtbl.find tbl s
|
|
with Not_found ->
|
|
let lbl = new_label() in
|
|
Hashtbl.add tbl s lbl;
|
|
num_literals := !num_literals + size;
|
|
lbl
|
|
|
|
(* Emit all pending constants *)
|
|
|
|
let emit_constants () =
|
|
Hashtbl.iter
|
|
(fun s lbl ->
|
|
`{emit_label lbl}: .word {emit_symbol s}\n`)
|
|
symbol_constants;
|
|
Hashtbl.iter
|
|
(fun s lbl ->
|
|
`{emit_label lbl}: .double {emit_string s}\n`)
|
|
float_constants;
|
|
Hashtbl.clear symbol_constants;
|
|
Hashtbl.clear float_constants;
|
|
num_literals := 0;
|
|
pending_float := false
|
|
|
|
(* Output the assembly code for an instruction *)
|
|
|
|
let emit_instr i =
|
|
match i.desc with
|
|
Lend -> 0
|
|
| Lop(Imove | Ispill | Ireload) ->
|
|
let src = i.arg.(0) and dst = i.res.(0) in
|
|
if src.loc = dst.loc then 0 else begin
|
|
match (src, dst) with
|
|
{loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
|
|
` mov {emit_reg dst}, {emit_reg src}\n`; 1
|
|
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
|
|
` mvfd {emit_reg dst}, {emit_reg src}\n`; 1
|
|
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Int|Addr} ->
|
|
` stfd {emit_reg src}, [sp, #-8]!\n`;
|
|
` ldmfd sp!, \{{emit_reg dst}, {emit_next_reg dst}}\n`; 2
|
|
| {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
|
|
` str {emit_reg src}, {emit_stack dst}\n`; 1
|
|
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
|
|
` stfd {emit_reg src}, {emit_stack dst}\n`; 1
|
|
| {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
|
|
` ldr {emit_reg dst}, {emit_stack src}\n`; 1
|
|
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
|
|
` ldfd {emit_reg dst}, {emit_stack src}\n`; 1
|
|
| _ ->
|
|
assert false
|
|
end
|
|
| Lop(Iconst_int n) ->
|
|
let r = i.res.(0) in
|
|
let nr = Nativeint.lognot n in
|
|
if is_immediate n then begin
|
|
` mov {emit_reg r}, #{emit_nativeint n}\n`; 1
|
|
end else if is_immediate nr then begin
|
|
` mvn {emit_reg r}, #{emit_nativeint nr}\n`; 1
|
|
end else
|
|
emit_complex_intconst r n
|
|
| Lop(Iconst_float s) ->
|
|
if float_of_string s = 0.0 then
|
|
` mvfd {emit_reg i.res.(0)}, #0.0\n`
|
|
else begin
|
|
let lbl = label_constant float_constants s 2 in
|
|
pending_float := true;
|
|
` ldfd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`
|
|
end;
|
|
1
|
|
| Lop(Iconst_symbol s) ->
|
|
let lbl = label_constant symbol_constants s 1 in
|
|
` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1
|
|
| Lop(Icall_ind) ->
|
|
` mov lr, pc\n`;
|
|
`{record_frame i.live} mov pc, {emit_reg i.arg.(0)}\n`; 2
|
|
| Lop(Icall_imm s) ->
|
|
`{record_frame i.live} bl {emit_symbol s}\n`; 1
|
|
| Lop(Itailcall_ind) ->
|
|
let n = frame_size() in
|
|
if !contains_calls then
|
|
` ldr lr, [sp, #{emit_int (n-4)}]\n`;
|
|
ignore (emit_stack_adjustment "add" n);
|
|
` mov pc, {emit_reg i.arg.(0)}\n`; 3
|
|
| Lop(Itailcall_imm s) ->
|
|
if s = !function_name then begin
|
|
` b {emit_label !tailrec_entry_point}\n`; 1
|
|
end else begin
|
|
let n = frame_size() in
|
|
if !contains_calls then
|
|
` ldr lr, [sp, #{emit_int (n-4)}]\n`;
|
|
ignore (emit_stack_adjustment "add" n);
|
|
` b {emit_symbol s}\n`; 3
|
|
end
|
|
| Lop(Iextcall(s, alloc)) ->
|
|
if alloc then begin
|
|
let lbl = label_constant symbol_constants s 1 in
|
|
` ldr r10, {emit_label lbl} @ {emit_symbol s}\n`;
|
|
`{record_frame i.live} bl caml_c_call\n`; 2
|
|
end else begin
|
|
` bl {emit_symbol s}\n`; 1
|
|
end
|
|
| Lop(Istackoffset n) ->
|
|
let ninstr =
|
|
if n >= 0
|
|
then emit_stack_adjustment "sub" n
|
|
else emit_stack_adjustment "add" (-n) in
|
|
stack_offset := !stack_offset + n;
|
|
ninstr
|
|
| Lop(Iload(Single, addr)) ->
|
|
let r = i.res.(0) in
|
|
` ldfs {emit_reg r}, {emit_addressing addr i.arg 0}\n`;
|
|
` mvfd {emit_reg r}, {emit_reg r}\n`;
|
|
2
|
|
| Lop(Iload(size, addr)) ->
|
|
let r = i.res.(0) in
|
|
let instr =
|
|
match size with
|
|
Byte_unsigned -> "ldrb"
|
|
| Byte_signed -> "ldrsb"
|
|
| Sixteen_unsigned -> "ldrh"
|
|
| Sixteen_signed -> "ldrsh"
|
|
| Double | Double_u -> "ldfd"
|
|
| _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "ldr" in
|
|
` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`;
|
|
1
|
|
| Lop(Istore(Single, addr)) ->
|
|
let r = i.arg.(0) in
|
|
` mvfs f7, {emit_reg r}\n`;
|
|
` stfs f7, {emit_addressing addr i.arg 1}\n`;
|
|
2
|
|
| Lop(Istore(size, addr)) ->
|
|
let r = i.arg.(0) in
|
|
let instr =
|
|
match size with
|
|
Byte_unsigned | Byte_signed -> "strb"
|
|
| Sixteen_unsigned | Sixteen_signed -> "strh"
|
|
| Double | Double_u -> "stfd"
|
|
| _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "str" in
|
|
` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`;
|
|
1
|
|
| Lop(Ialloc n) ->
|
|
if !fastcode_flag then begin
|
|
` ldr r10, [alloc_limit, #0]\n`;
|
|
let ni = emit_alloc_decrement n in
|
|
` cmp alloc_ptr, r10\n`;
|
|
`{record_frame i.live} blcc caml_call_gc\n`;
|
|
` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
|
|
4 + ni
|
|
end else if n = 8 || n = 12 || n = 16 then begin
|
|
`{record_frame i.live} bl caml_alloc{emit_int ((n-4)/4)}\n`;
|
|
` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2
|
|
end else begin
|
|
let nn = Nativeint.of_int n in
|
|
let ni =
|
|
if is_immediate nn then begin
|
|
` mov r10, #{emit_int n}\n`; 1
|
|
end else
|
|
emit_complex_intconst (phys_reg 8 (*r10*)) nn in
|
|
`{record_frame i.live} bl caml_alloc\n`;
|
|
` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
|
|
2 + ni
|
|
end
|
|
| Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
|
|
let shift = name_for_shift_operation op in
|
|
` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1
|
|
| Lop(Iintop(Icomp cmp)) ->
|
|
let comp = name_for_comparison cmp in
|
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
` mov {emit_reg i.res.(0)}, #0\n`;
|
|
` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3
|
|
| Lop(Iintop(Icheckbound)) ->
|
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
` blls caml_array_bound_error\n`; 2
|
|
| Lop(Iintop op) ->
|
|
let instr = name_for_int_operation op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
|
|
| Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
let r = i.res.(0) in
|
|
` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`;
|
|
if n <= 256 then
|
|
` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n`
|
|
else begin
|
|
` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
|
|
` sublt {emit_reg r}, {emit_reg r}, #1\n`
|
|
end;
|
|
` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4
|
|
| Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
let a = i.arg.(0) in
|
|
let r = i.res.(0) in
|
|
let lbl = new_label() in
|
|
` cmp {emit_reg a}, #0\n`;
|
|
` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`;
|
|
` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`;
|
|
` bpl {emit_label lbl}\n`;
|
|
` cmp {emit_reg r}, #0\n`;
|
|
` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
|
|
`{emit_label lbl}:\n`; 6
|
|
| Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) ->
|
|
let shift = name_for_shift_operation op in
|
|
` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1
|
|
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
|
let comp = name_for_comparison cmp in
|
|
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
` mov {emit_reg i.res.(0)}, #0\n`;
|
|
` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3
|
|
| Lop(Iintop_imm(Icheckbound, n)) ->
|
|
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
` blls caml_array_bound_error\n`; 2
|
|
| Lop(Iintop_imm(op, n)) ->
|
|
let instr = name_for_int_operation op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
|
|
| Lop(Inegf | Iabsf | Ifloatofint | Iintoffloat as op) ->
|
|
let instr = name_for_float_operation op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
|
|
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
|
let instr = name_for_float_operation op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
|
|
| Lop(Ispecific(Ishiftarith(op, shift))) ->
|
|
let instr = name_for_shift_int_operation op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
|
|
if shift >= 0
|
|
then `, lsl #{emit_int shift}\n`
|
|
else `, asr #{emit_int (-shift)}\n`;
|
|
1
|
|
| Lop(Ispecific(Ishiftcheckbound shift)) ->
|
|
` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
|
|
` blcs caml_array_bound_error\n`; 2
|
|
| Lop(Ispecific(Irevsubimm n)) ->
|
|
` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
|
|
| Lreloadretaddr ->
|
|
let n = frame_size() in
|
|
` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1
|
|
| Lreturn ->
|
|
let n = frame_size() in
|
|
ignore(emit_stack_adjustment "add" n);
|
|
` mov pc, lr\n`; 2
|
|
| Llabel lbl ->
|
|
`{emit_label lbl}:\n`; 0
|
|
| Lbranch lbl ->
|
|
` b {emit_label lbl}\n`; 1
|
|
| Lcondbranch(tst, lbl) ->
|
|
begin match tst with
|
|
Itruetest ->
|
|
` cmp {emit_reg i.arg.(0)}, #0\n`;
|
|
` bne {emit_label lbl}\n`
|
|
| Ifalsetest ->
|
|
` cmp {emit_reg i.arg.(0)}, #0\n`;
|
|
` beq {emit_label lbl}\n`
|
|
| Iinttest cmp ->
|
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
let comp = name_for_comparison cmp in
|
|
` b{emit_string comp} {emit_label lbl}\n`
|
|
| Iinttest_imm(cmp, n) ->
|
|
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
let comp = name_for_comparison cmp in
|
|
` b{emit_string comp} {emit_label lbl}\n`
|
|
| Ifloattest(cmp, neg) ->
|
|
begin match cmp with
|
|
Ceq | Cne ->
|
|
` cmf {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
|
| _ ->
|
|
` cmfe {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
|
end;
|
|
let comp = name_for_float_comparison cmp neg in
|
|
` b{emit_string comp} {emit_label lbl}\n`
|
|
| Ioddtest ->
|
|
` tst {emit_reg i.arg.(0)}, #1\n`;
|
|
` bne {emit_label lbl}\n`
|
|
| Ieventest ->
|
|
` tst {emit_reg i.arg.(0)}, #1\n`;
|
|
` beq {emit_label lbl}\n`
|
|
end;
|
|
2
|
|
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
|
` cmp {emit_reg i.arg.(0)}, #1\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;
|
|
4
|
|
| Lswitch jumptbl ->
|
|
` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
|
|
` mov r0, r0\n`; (* nop *)
|
|
for i = 0 to Array.length jumptbl - 1 do
|
|
` .word {emit_label jumptbl.(i)}\n`
|
|
done;
|
|
2 + Array.length jumptbl
|
|
| Lsetuptrap lbl ->
|
|
` bl {emit_label lbl}\n`; 1
|
|
| Lpushtrap ->
|
|
stack_offset := !stack_offset + 8;
|
|
` stmfd sp!, \{trap_ptr, lr}\n`;
|
|
` mov trap_ptr, sp\n`; 2
|
|
| Lpoptrap ->
|
|
` ldmfd sp!, \{trap_ptr, lr}\n`;
|
|
stack_offset := !stack_offset - 8; 1
|
|
| Lraise ->
|
|
` mov sp, trap_ptr\n`;
|
|
` ldmfd sp!, \{trap_ptr, pc}\n`; 2
|
|
|
|
(* Emission of an instruction sequence *)
|
|
|
|
let no_fallthrough = function
|
|
Lop(Itailcall_ind | Itailcall_imm _) -> true
|
|
| Lreturn -> true
|
|
| Lbranch _ -> true
|
|
| Lswitch _ -> true
|
|
| Lraise -> true
|
|
| _ -> false
|
|
|
|
let rec emit_all ninstr i =
|
|
if i.desc = Lend then () else begin
|
|
let n = emit_instr i in
|
|
let ninstr' = ninstr + n in
|
|
let limit = (if !pending_float then 127 else 511) - !num_literals in
|
|
if ninstr' >= limit - 32 && no_fallthrough i.desc then begin
|
|
emit_constants();
|
|
emit_all 0 i.next
|
|
end else
|
|
if ninstr' >= limit then begin
|
|
let lbl = new_label() in
|
|
` b {emit_label lbl}\n`;
|
|
emit_constants();
|
|
`{emit_label lbl}:\n`;
|
|
emit_all 0 i.next
|
|
end else
|
|
emit_all ninstr' i.next
|
|
end
|
|
|
|
(* 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;
|
|
Hashtbl.clear symbol_constants;
|
|
Hashtbl.clear float_constants;
|
|
` .text\n`;
|
|
` .align 0\n`;
|
|
` .global {emit_symbol fundecl.fun_name}\n`;
|
|
`{emit_symbol fundecl.fun_name}:\n`;
|
|
let n = frame_size() in
|
|
ignore(emit_stack_adjustment "sub" n);
|
|
if !contains_calls then
|
|
` str lr, [sp, #{emit_int(n - 4)}]\n`;
|
|
`{emit_label !tailrec_entry_point}:\n`;
|
|
emit_all 0 fundecl.fun_body;
|
|
emit_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 (10000 + lbl)}:\n`
|
|
| Cint8 n ->
|
|
` .byte {emit_int n}\n`
|
|
| Cint16 n ->
|
|
` .short {emit_int n}\n`
|
|
| Cint32 n ->
|
|
` .word {emit_nativeint n}\n`
|
|
| Cint n ->
|
|
` .word {emit_nativeint n}\n`
|
|
| Csingle f ->
|
|
` .float {emit_string f}\n`
|
|
| Cdouble f ->
|
|
` .align 0\n`;
|
|
` .double {emit_string f}\n`
|
|
| Csymbol_address s ->
|
|
` .word {emit_symbol s}\n`
|
|
| Clabel_address lbl ->
|
|
` .word {emit_label (10000 + lbl)}\n`
|
|
| Cstring s ->
|
|
emit_string_directive " .ascii " s
|
|
| Cskip n ->
|
|
if n > 0 then ` .space {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() =
|
|
`trap_ptr .req r11\n`;
|
|
`alloc_ptr .req r8\n`;
|
|
`alloc_limit .req r9\n`;
|
|
`sp .req r13\n`;
|
|
`lr .req r14\n`;
|
|
`pc .req r15\n`;
|
|
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
|
` .data\n`;
|
|
` .global {emit_symbol lbl_begin}\n`;
|
|
`{emit_symbol lbl_begin}:\n`;
|
|
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
|
` .text\n`;
|
|
` .global {emit_symbol lbl_begin}\n`;
|
|
`{emit_symbol lbl_begin}:\n`
|
|
|
|
let end_assembly () =
|
|
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
|
` .text\n`;
|
|
` .global {emit_symbol lbl_end}\n`;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
|
` .data\n`;
|
|
` .global {emit_symbol lbl_end}\n`;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
` .word 0\n`;
|
|
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 := []
|