961 lines
32 KiB
Plaintext
961 lines
32 KiB
Plaintext
(***********************************************************************)
|
|
(* *)
|
|
(* 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 PowerPC assembly code *)
|
|
|
|
module StringSet = Set.Make(struct type t = string let compare = compare end)
|
|
|
|
open Misc
|
|
open Cmm
|
|
open Arch
|
|
open Proc
|
|
open Reg
|
|
open Mach
|
|
open Linearize
|
|
open Emitaux
|
|
|
|
(* Layout of the stack *)
|
|
|
|
(* In the TOC-based model:
|
|
The bottom 24 bytes of the stack are reserved at all times
|
|
for a standard linkage area.
|
|
In this area, the word at offset +20 is used by glue code and others to
|
|
save the TOC register.
|
|
The bottom two words are used as temporaries and for trap frames.
|
|
The stack is kept 8-aligned.
|
|
In the absolute-address model:
|
|
No reserved space at the bottom of the stack.
|
|
The stack is kept 8-aligned. *)
|
|
|
|
let stack_linkage_area = if toc then 24 else 0
|
|
let trap_frame_size = if toc then 24 else 8
|
|
|
|
let stack_offset = ref 0
|
|
|
|
let frame_size () =
|
|
let size =
|
|
stack_linkage_area + (* The bottom linkage area *)
|
|
!stack_offset + (* Trap frame, outgoing parameters *)
|
|
4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + (* Local variables *)
|
|
(if !contains_calls then 4 else 0) in (* The return address *)
|
|
Misc.align size 8
|
|
|
|
let slot_offset loc cls =
|
|
match loc with
|
|
Local n ->
|
|
if cls = 0
|
|
then stack_linkage_area + !stack_offset + num_stack_slots.(1) * 8 + n * 4
|
|
else stack_linkage_area + !stack_offset + n * 8
|
|
| Incoming n -> frame_size() + n
|
|
| Outgoing n -> n
|
|
|
|
(* Output a symbol *)
|
|
|
|
let emit_symbol =
|
|
match Config.system with
|
|
"aix" | "elf" -> (fun s -> Emitaux.emit_symbol '.' s)
|
|
| "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s)
|
|
| _ -> assert false
|
|
|
|
let emit_codesymbol s =
|
|
if toc then emit_char '.';
|
|
emit_symbol s
|
|
|
|
(* Output a label *)
|
|
|
|
let label_prefix =
|
|
match Config.system with
|
|
"aix" -> "L.."
|
|
| "elf" -> ".L"
|
|
| "rhapsody" -> "L"
|
|
| _ -> assert false
|
|
|
|
let emit_label lbl =
|
|
emit_string label_prefix; emit_int lbl
|
|
|
|
(* Section switching *)
|
|
|
|
let data_space =
|
|
match Config.system with
|
|
"aix" -> " .csect .data[RW]\n"
|
|
| "elf" -> " .section \".data\"\n"
|
|
| "rhapsody" -> " .data\n"
|
|
| _ -> assert false
|
|
|
|
let code_space =
|
|
match Config.system with
|
|
"aix" -> " .csect .text[PR]\n"
|
|
| "elf" -> " .section \".text\"\n"
|
|
| "rhapsody" -> " .text\n"
|
|
| _ -> assert false
|
|
|
|
let rodata_space =
|
|
match Config.system with
|
|
"aix" -> " .csect .data[RW]\n" (* ?? *)
|
|
| "elf" -> " .section \".rodata\"\n"
|
|
| "rhapsody" -> " .const\n"
|
|
| _ -> assert false
|
|
|
|
(* Output a pseudo-register *)
|
|
|
|
let emit_reg r =
|
|
match r.loc with
|
|
Reg r -> emit_string (register_name r)
|
|
| _ -> fatal_error "Emit.emit_reg"
|
|
|
|
let use_full_regnames =
|
|
Config.system = "rhapsody"
|
|
|
|
let emit_gpr r =
|
|
if use_full_regnames then emit_char 'r';
|
|
emit_int r
|
|
|
|
let emit_fpr r =
|
|
if use_full_regnames then emit_char 'f';
|
|
emit_int r
|
|
|
|
let emit_ccr r =
|
|
if use_full_regnames then emit_string "cr";
|
|
emit_int r
|
|
|
|
(* Output a stack reference *)
|
|
|
|
let emit_stack r =
|
|
match r.loc with
|
|
Stack s ->
|
|
let ofs = slot_offset s (register_class r) in `{emit_int ofs}({emit_gpr 1})`
|
|
| _ -> fatal_error "Emit.emit_stack"
|
|
|
|
(* Split a 32-bit integer constants in two 16-bit halves *)
|
|
|
|
let low n = n land 0xFFFF
|
|
let high n = n asr 16
|
|
|
|
let nativelow n = Nativeint.to_int n land 0xFFFF
|
|
let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16)
|
|
|
|
let is_immediate n =
|
|
n <= 32767 && n >= -32768
|
|
|
|
let is_native_immediate n =
|
|
n <= Nativeint.of_int 32767 && n >= Nativeint.of_int (-32768)
|
|
|
|
(* Output a "upper 16 bits" or "lower 16 bits" operator
|
|
(for the absolute addressing mode) *)
|
|
|
|
let emit_upper emit_fun arg =
|
|
match Config.system with
|
|
"elf" ->
|
|
emit_fun arg; emit_string "@ha"
|
|
| "rhapsody" ->
|
|
emit_string "ha16("; emit_fun arg; emit_string ")"
|
|
| _ -> assert false
|
|
|
|
let emit_lower emit_fun arg =
|
|
match Config.system with
|
|
"elf" ->
|
|
emit_fun arg; emit_string "@l"
|
|
| "rhapsody" ->
|
|
emit_string "lo16("; emit_fun arg; emit_string ")"
|
|
| _ -> assert false
|
|
|
|
(* Output a load or store operation *)
|
|
|
|
let emit_symbol_offset (s, d) =
|
|
emit_symbol s;
|
|
if d > 0 then `+`;
|
|
if d <> 0 then emit_int d
|
|
|
|
let emit_load_store instr addressing_mode addr n arg =
|
|
match addressing_mode with
|
|
Ibased(s, d) ->
|
|
(* Only relevant in the absolute model *)
|
|
` addis {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`;
|
|
` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n`
|
|
| Iindexed ofs ->
|
|
if is_immediate ofs then
|
|
` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
|
|
else begin
|
|
` lis {emit_gpr 0}, {emit_int(high ofs)}\n`;
|
|
if low ofs <> 0 then
|
|
` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`;
|
|
` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n`
|
|
end
|
|
| Iindexed2 ->
|
|
` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n`
|
|
|
|
(* After a comparison, extract the result as 0 or 1 *)
|
|
|
|
let emit_set_comp cmp res =
|
|
` mfcr {emit_gpr 0}\n`;
|
|
let bitnum =
|
|
match cmp with
|
|
Ceq | Cne -> 2
|
|
| Cgt | Cle -> 1
|
|
| Clt | Cge -> 0 in
|
|
` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`;
|
|
begin match cmp with
|
|
Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\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 =
|
|
` .long {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`
|
|
|
|
(* Record symbols and floating-point constants (for the TOC model).
|
|
These will go in the toc section. *)
|
|
|
|
let label_constant table constant =
|
|
try
|
|
Hashtbl.find table constant
|
|
with Not_found ->
|
|
let lbl = new_label() in
|
|
Hashtbl.add table constant lbl;
|
|
lbl
|
|
|
|
let symbol_constants = (Hashtbl.create 17 : (string, int) Hashtbl.t)
|
|
let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
|
|
|
let label_symbol s = label_constant symbol_constants s
|
|
let label_float s = label_constant float_constants s
|
|
|
|
let emit_symbol_constant symb lbl =
|
|
`{emit_label lbl}: .tc {emit_symbol symb}[TC], {emit_symbol symb}\n`
|
|
|
|
let emit_float_constant float lbl =
|
|
`{emit_label lbl}: .tc FD_`;
|
|
for i = 0 to 7 do
|
|
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
|
done;
|
|
`[TC], 0x`;
|
|
for i = 0 to 3 do
|
|
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
|
done;
|
|
`, 0x`;
|
|
for i = 4 to 7 do
|
|
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
|
done;
|
|
`\n`
|
|
|
|
(* Record floating-point literals (for the ELF model) *)
|
|
|
|
let float_literals = ref ([] : (string * int) list)
|
|
|
|
(* Record external C functions to be called in a position-independent way
|
|
(for Rhapsody) *)
|
|
|
|
let pic_externals = (Config.system = "rhapsody")
|
|
|
|
let external_functions = ref StringSet.empty
|
|
|
|
let emit_external s =
|
|
` .non_lazy_symbol_pointer\n`;
|
|
`L{emit_symbol s}$non_lazy_ptr:\n`;
|
|
` .indirect_symbol {emit_symbol s}\n`;
|
|
` .long 0\n`
|
|
|
|
(* Names for conditional branches after comparisons *)
|
|
|
|
let branch_for_comparison = function
|
|
Ceq -> "beq" | Cne -> "bne"
|
|
| Cle -> "ble" | Cgt -> "bgt"
|
|
| Cge -> "bge" | Clt -> "blt"
|
|
|
|
let name_for_int_comparison = function
|
|
Isigned cmp -> ("cmpw", branch_for_comparison cmp)
|
|
| Iunsigned cmp -> ("cmplw", branch_for_comparison cmp)
|
|
|
|
(* Names for various instructions *)
|
|
|
|
let name_for_intop = function
|
|
Iadd -> "add"
|
|
| Imul -> "mullw"
|
|
| Idiv -> if powerpc then "divw" else "divs"
|
|
| Iand -> "and"
|
|
| Ior -> "or"
|
|
| Ixor -> "xor"
|
|
| Ilsl -> "slw"
|
|
| Ilsr -> "srw"
|
|
| Iasr -> "sraw"
|
|
| _ -> Misc.fatal_error "Emit.Intop"
|
|
|
|
let name_for_intop_imm = function
|
|
Iadd -> "addi"
|
|
| Imul -> "mulli"
|
|
| Iand -> "andi."
|
|
| Ior -> "ori"
|
|
| Ixor -> "xori"
|
|
| Ilsl -> "slwi"
|
|
| Ilsr -> "srwi"
|
|
| Iasr -> "srawi"
|
|
| _ -> Misc.fatal_error "Emit.Intop_imm"
|
|
|
|
let name_for_floatop1 = function
|
|
Inegf -> "fneg"
|
|
| Iabsf -> "fabs"
|
|
| _ -> Misc.fatal_error "Emit.Iopf1"
|
|
|
|
let name_for_floatop2 = function
|
|
Iaddf -> "fadd"
|
|
| Isubf -> "fsub"
|
|
| Imulf -> "fmul"
|
|
| Idivf -> "fdiv"
|
|
| _ -> Misc.fatal_error "Emit.Iopf2"
|
|
|
|
let name_for_specific = function
|
|
Imultaddf -> "fmadd"
|
|
| Imultsubf -> "fmsub"
|
|
|
|
(* Name of current function *)
|
|
let function_name = ref ""
|
|
(* Entry point for tail recursive calls *)
|
|
let tailrec_entry_point = ref 0
|
|
(* Names of functions defined in the current file *)
|
|
let defined_functions = ref StringSet.empty
|
|
(* Label of glue code for calling the GC *)
|
|
let call_gc_label = ref 0
|
|
(* Label of jump table *)
|
|
let lbl_jumptbl = ref 0
|
|
(* List of all labels in jumptable (reverse order) *)
|
|
let jumptbl_entries = ref []
|
|
(* Number of jumptable entries *)
|
|
let num_jumptbl_entries = ref 0
|
|
|
|
(* Output the assembly code for an instruction *)
|
|
|
|
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
|
|
if src.loc <> dst.loc then begin
|
|
match (src, dst) with
|
|
{loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
|
|
` mr {emit_reg dst}, {emit_reg src}\n`
|
|
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
|
|
` fmr {emit_reg dst}, {emit_reg src}\n`
|
|
| {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
|
|
` stw {emit_reg src}, {emit_stack dst}\n`
|
|
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
|
|
` stfd {emit_reg src}, {emit_stack dst}\n`
|
|
| {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
|
|
` lwz {emit_reg dst}, {emit_stack src}\n`
|
|
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
|
|
` lfd {emit_reg dst}, {emit_stack src}\n`
|
|
| (_, _) ->
|
|
fatal_error "Emit: Imove"
|
|
end
|
|
| Lop(Iconst_int n) ->
|
|
if is_native_immediate n then
|
|
` li {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
|
else begin
|
|
` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`;
|
|
if nativelow n <> 0 then
|
|
` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n`
|
|
end
|
|
| Lop(Iconst_float s) ->
|
|
if toc then begin
|
|
let repr = (Obj.magic (float_of_string s) : string) in
|
|
let lbl = label_float repr in
|
|
` lfd {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_string s}\n`
|
|
end else begin
|
|
let lbl = new_label() in
|
|
float_literals := (s, lbl) :: !float_literals;
|
|
` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
|
|
` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
|
|
end
|
|
| Lop(Iconst_symbol s) ->
|
|
if toc then begin
|
|
let lbl = label_symbol s in
|
|
` lwz {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_symbol s}\n`
|
|
end else begin
|
|
` addis {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`;
|
|
` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n`
|
|
end
|
|
| Lop(Icall_ind) ->
|
|
if toc then begin
|
|
` lwz 0, 0({emit_reg i.arg.(0)})\n`;
|
|
` stw 2, 20(1)\n`;
|
|
` mtlr 0\n`;
|
|
` lwz 2, 4({emit_reg i.arg.(0)})\n`;
|
|
record_frame i.live;
|
|
` blrl\n`;
|
|
` lwz 2, 20(1)\n`
|
|
end else begin
|
|
` mtlr {emit_reg i.arg.(0)}\n`;
|
|
record_frame i.live;
|
|
` blrl\n`
|
|
end
|
|
| Lop(Icall_imm s) ->
|
|
record_frame i.live;
|
|
` bl {emit_codesymbol s}\n`;
|
|
if toc && not (StringSet.mem s !defined_functions) then
|
|
` cror 31, 31, 31\n` (* nop *)
|
|
| Lop(Itailcall_ind) ->
|
|
let n = frame_size() in
|
|
if toc then begin
|
|
` lwz 0, 0({emit_reg i.arg.(0)})\n`;
|
|
` lwz 2, 4({emit_reg i.arg.(0)})\n`;
|
|
` mtctr 0\n`
|
|
end else begin
|
|
` mtctr {emit_reg i.arg.(0)}\n`
|
|
end;
|
|
if !contains_calls then begin
|
|
` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
|
|
` mtlr {emit_gpr 11}\n`
|
|
end else begin
|
|
if n > 0 then
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`
|
|
end;
|
|
` bctr\n`
|
|
| Lop(Itailcall_imm s) ->
|
|
if s = !function_name then
|
|
` b {emit_label !tailrec_entry_point}\n`
|
|
else if not toc || StringSet.mem s !defined_functions then begin
|
|
let n = frame_size() in
|
|
if !contains_calls then begin
|
|
` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
|
|
` mtlr {emit_gpr 11}\n`
|
|
end else begin
|
|
if n > 0 then
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`
|
|
end;
|
|
` b {emit_codesymbol s}\n`
|
|
end else begin
|
|
(* Tailcalling a function that has a possibly different TOC
|
|
is difficult, because the callee's TOC must be loaded in r2,
|
|
but ours must not be stored in 20(r1), which would overwrite
|
|
our caller's saved TOC. Hence we can't go through the
|
|
standard glue code. Here, we just proceed as in tailcall_ind. *)
|
|
let lbl = label_symbol s in
|
|
let n = frame_size() in
|
|
` lwz 12, {emit_label lbl}(2) # {emit_symbol s}\n`;
|
|
if !contains_calls then begin
|
|
` lwz 11, {emit_int(n - 4)}(1)\n`;
|
|
` lwz 0, 0(12)\n`;
|
|
` lwz 2, 4(12)\n`;
|
|
` mtctr 0\n`;
|
|
` addi 1, 1, {emit_int n}\n`;
|
|
` mtlr 11\n`
|
|
end else begin
|
|
` lwz 0, 0(12)\n`;
|
|
` lwz 2, 4(12)\n`;
|
|
` mtctr 0\n`;
|
|
if n > 0 then
|
|
` addi 1, 1, {emit_int n}\n`
|
|
end;
|
|
` bctr\n`
|
|
end
|
|
| Lop(Iextcall(s, alloc)) ->
|
|
if alloc then begin
|
|
if toc then begin
|
|
let lbl = label_symbol s in
|
|
` lwz 11, {emit_label lbl}(2) # {emit_symbol s}\n`
|
|
end else if pic_externals then begin
|
|
external_functions := StringSet.add s !external_functions;
|
|
` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`;
|
|
` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`
|
|
end else begin
|
|
` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`;
|
|
` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n`
|
|
end;
|
|
record_frame i.live;
|
|
` bl {emit_codesymbol "caml_c_call"}\n`
|
|
end else begin
|
|
if pic_externals then begin
|
|
external_functions := StringSet.add s !external_functions;
|
|
` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`;
|
|
` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`;
|
|
` mtlr {emit_gpr 11}\n`;
|
|
` blrl\n`
|
|
end else
|
|
` bl {emit_codesymbol s}\n`
|
|
end;
|
|
if toc then
|
|
` cror 31, 31, 31\n` (* nop *)
|
|
| Lop(Istackoffset n) ->
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`;
|
|
stack_offset := !stack_offset + n
|
|
| Lop(Iload(chunk, addr)) ->
|
|
let loadinstr =
|
|
match chunk with
|
|
Byte_unsigned -> "lbz"
|
|
| Byte_signed -> "lbz"
|
|
| Sixteen_unsigned -> "lhz"
|
|
| Sixteen_signed -> "lha"
|
|
| Single -> "lfs"
|
|
| Double -> "lfd"
|
|
| _ -> "lwz" in
|
|
emit_load_store loadinstr addr i.arg 0 i.res.(0);
|
|
if chunk = Byte_signed then
|
|
` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Istore(chunk, addr)) ->
|
|
let storeinstr =
|
|
match chunk with
|
|
Byte_unsigned | Byte_signed -> "stb"
|
|
| Sixteen_unsigned | Sixteen_signed -> "sth"
|
|
| Single -> "stfs"
|
|
| Double -> "stfd"
|
|
| _ -> "stw" in
|
|
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
|
|
| Lop(Ialloc n) ->
|
|
if !call_gc_label = 0 then call_gc_label := new_label();
|
|
` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`;
|
|
` cmplw {emit_gpr 31}, {emit_gpr 30}\n`;
|
|
` addi {emit_reg i.res.(0)}, {emit_gpr 31}, 4\n`;
|
|
record_frame i.live;
|
|
` bltl {emit_label !call_gc_label}\n`
|
|
| Lop(Iintop Isub) -> (* subf has swapped arguments *)
|
|
(* Use subfc instead of subf for RS6000 compatibility. *)
|
|
` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
|
|
| Lop(Iintop Imod) ->
|
|
if powerpc then begin
|
|
` divw {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
` mullw {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`;
|
|
` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
|
|
end else begin
|
|
` divs {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
` mfmq {emit_reg i.res.(0)}\n`
|
|
end
|
|
| Lop(Iintop(Icomp cmp)) ->
|
|
begin match cmp with
|
|
Isigned c ->
|
|
` cmpw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
emit_set_comp c i.res.(0)
|
|
| Iunsigned c ->
|
|
` cmplw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
emit_set_comp c i.res.(0)
|
|
end
|
|
| Lop(Iintop Icheckbound) ->
|
|
` twlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
|
| Lop(Iintop op) ->
|
|
let instr = name_for_intop op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
|
| Lop(Iintop_imm(Isub, n)) ->
|
|
` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
|
|
| Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
` srawi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
|
` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
|
| Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
` srawi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
|
` addze {emit_gpr 0}, {emit_gpr 0}\n`;
|
|
` slwi {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`;
|
|
` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
|
|
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
|
begin match cmp with
|
|
Isigned c ->
|
|
` cmpwi {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
|
emit_set_comp c i.res.(0)
|
|
| Iunsigned c ->
|
|
` cmplwi {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
|
emit_set_comp c i.res.(0)
|
|
end
|
|
| Lop(Iintop_imm(Icheckbound, n)) ->
|
|
` twllei {emit_reg i.arg.(0)}, {emit_int n}\n`
|
|
| Lop(Iintop_imm(op, n)) ->
|
|
let instr = name_for_intop_imm op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
|
|
| Lop(Inegf | Iabsf as op) ->
|
|
let instr = name_for_floatop1 op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
|
|
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
|
let instr = name_for_floatop2 op in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
|
| Lop(Ifloatofint) ->
|
|
if toc then begin
|
|
let lbl = label_float "\067\048\000\000\128\000\000\000" in
|
|
(* That string above represents 0x4330000080000000 *)
|
|
` lfd 0, {emit_label lbl}(2)\n`
|
|
end else begin
|
|
let lbl = new_label() in
|
|
float_literals := ("4.503601774854144e15", lbl) :: !float_literals;
|
|
(* That float above also represents 0x4330000080000000 *)
|
|
` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
|
|
` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
|
|
end;
|
|
` lis {emit_gpr 0}, 0x4330\n`;
|
|
` stwu {emit_gpr 0}, -8({emit_gpr 1})\n`;
|
|
` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`;
|
|
` stw {emit_gpr 0}, 4({emit_gpr 1})\n`;
|
|
` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, 8\n`;
|
|
` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n`
|
|
| Lop(Iintoffloat) ->
|
|
` fctiwz {emit_fpr 0}, {emit_reg i.arg.(0)}\n`;
|
|
` stfdu {emit_fpr 0}, -8({emit_gpr 1})\n`;
|
|
` lwz {emit_reg i.res.(0)}, 4({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, 8\n`
|
|
| Lop(Ispecific sop) ->
|
|
let instr = name_for_specific sop in
|
|
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
|
|
| Lreloadretaddr ->
|
|
let n = frame_size() in
|
|
` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`;
|
|
` mtlr {emit_gpr 11}\n`
|
|
| Lreturn ->
|
|
let n = frame_size() in
|
|
if n > 0 then
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
|
|
` blr\n`
|
|
| Llabel lbl ->
|
|
`{emit_label lbl}:\n`
|
|
| Lbranch lbl ->
|
|
` b {emit_label lbl}\n`
|
|
| Lcondbranch(tst, lbl) ->
|
|
begin match tst with
|
|
Itruetest ->
|
|
` cmpwi {emit_reg i.arg.(0)}, 0\n`;
|
|
emit_delay dslot;
|
|
` bne {emit_label lbl}\n`
|
|
| Ifalsetest ->
|
|
` cmpwi {emit_reg i.arg.(0)}, 0\n`;
|
|
emit_delay dslot;
|
|
` beq {emit_label lbl}\n`
|
|
| Iinttest cmp ->
|
|
let (comp, branch) = name_for_int_comparison cmp in
|
|
` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
emit_delay dslot;
|
|
` {emit_string branch} {emit_label lbl}\n`
|
|
| Iinttest_imm(cmp, n) ->
|
|
let (comp, branch) = name_for_int_comparison cmp in
|
|
` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
|
emit_delay dslot;
|
|
` {emit_string branch} {emit_label lbl}\n`
|
|
| Ifloattest(cmp, neg) ->
|
|
` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
(* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
|
|
let (bitnum, negtst) =
|
|
match cmp with
|
|
Ceq -> (2, neg)
|
|
| Cne -> (2, not neg)
|
|
| Cle -> ` cror 3, 0, 2\n`; (* lt or eq *)
|
|
(3, neg)
|
|
| Cgt -> (1, neg)
|
|
| Cge -> ` cror 3, 1, 2\n`; (* gt or eq *)
|
|
(3, neg)
|
|
| Clt -> (0, neg) in
|
|
emit_delay dslot;
|
|
if negtst
|
|
then ` bf {emit_int bitnum}, {emit_label lbl}\n`
|
|
else ` bt {emit_int bitnum}, {emit_label lbl}\n`
|
|
| Ioddtest ->
|
|
` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`;
|
|
emit_delay dslot;
|
|
` bne {emit_label lbl}\n`
|
|
| Ieventest ->
|
|
` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`;
|
|
emit_delay dslot;
|
|
` beq {emit_label lbl}\n`
|
|
end
|
|
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
|
` cmpwi {emit_reg i.arg.(0)}, 1\n`;
|
|
emit_delay dslot;
|
|
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
|
|
| Lswitch jumptbl ->
|
|
if !lbl_jumptbl = 0 then lbl_jumptbl := new_label();
|
|
if toc then begin
|
|
` lwz 11, {emit_label !lbl_jumptbl}(2)\n`
|
|
end else begin
|
|
` addis {emit_gpr 11}, 0, {emit_upper emit_label !lbl_jumptbl}\n`;
|
|
` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label !lbl_jumptbl}\n`
|
|
end;
|
|
` addi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`;
|
|
` slwi {emit_gpr 0}, {emit_gpr 0}, 2\n`;
|
|
` lwzx {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`;
|
|
` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`;
|
|
` mtctr {emit_gpr 0}\n`;
|
|
` bctr\n`;
|
|
for i = 0 to Array.length jumptbl - 1 do
|
|
jumptbl_entries := jumptbl.(i) :: !jumptbl_entries;
|
|
incr num_jumptbl_entries
|
|
done
|
|
| Lsetuptrap lbl ->
|
|
` bl {emit_label lbl}\n`
|
|
| Lpushtrap ->
|
|
stack_offset := !stack_offset + trap_frame_size;
|
|
` mflr {emit_gpr 0}\n`;
|
|
` stwu {emit_gpr 0}, -{emit_int trap_frame_size}({emit_gpr 1})\n`;
|
|
` stw {emit_gpr 29}, 4({emit_gpr 1})\n`;
|
|
if toc then
|
|
` stw {emit_gpr 2}, 20({emit_gpr 1})\n`;
|
|
` mr {emit_gpr 29}, {emit_gpr 1}\n`
|
|
| Lpoptrap ->
|
|
` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int trap_frame_size}\n`;
|
|
stack_offset := !stack_offset - trap_frame_size
|
|
| Lraise ->
|
|
` lwz {emit_gpr 0}, 0({emit_gpr 29})\n`;
|
|
` mr {emit_gpr 1}, {emit_gpr 29}\n`;
|
|
` mtlr {emit_gpr 0}\n`;
|
|
` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`;
|
|
if toc then
|
|
` lwz {emit_gpr 2}, 20({emit_gpr 1})\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int trap_frame_size}\n\n`;
|
|
` blr\n`
|
|
|
|
and emit_delay = function
|
|
None -> ()
|
|
| Some i -> emit_instr i None
|
|
|
|
(* Checks if a pseudo-instruction expands to instructions
|
|
that do not branch and do not affect CR0 nor R12. *)
|
|
|
|
let is_simple_instr i =
|
|
match i.desc with
|
|
Lop op ->
|
|
begin match op with
|
|
Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind |
|
|
Iextcall(_, _) -> false
|
|
| Ialloc(_) -> false
|
|
| Iintop(Icomp _) -> false
|
|
| Iintop_imm(Iand, _) -> false
|
|
| Iintop_imm(Icomp _, _) -> false
|
|
| _ -> true
|
|
end
|
|
| Lreloadretaddr -> true
|
|
| _ -> 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 = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}}
|
|
when is_simple_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;
|
|
defined_functions := StringSet.add fundecl.fun_name !defined_functions;
|
|
tailrec_entry_point := new_label();
|
|
stack_offset := 0;
|
|
call_gc_label := 0;
|
|
float_literals := [];
|
|
` .globl {emit_symbol fundecl.fun_name}\n`;
|
|
begin match Config.system with
|
|
"aix" ->
|
|
` .globl .{emit_symbol fundecl.fun_name}\n`;
|
|
` .csect {emit_symbol fundecl.fun_name}[DS]\n`;
|
|
`{emit_symbol fundecl.fun_name}:\n`;
|
|
` .long .{emit_symbol fundecl.fun_name}, TOC[tc0], 0\n`
|
|
| "elf" ->
|
|
` .type {emit_symbol fundecl.fun_name}, @function\n`
|
|
| _ -> ()
|
|
end;
|
|
emit_string code_space;
|
|
` .align 2\n`;
|
|
`{emit_codesymbol fundecl.fun_name}:\n`;
|
|
let n = frame_size() in
|
|
if !contains_calls then begin
|
|
` mflr {emit_gpr 0}\n`;
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`;
|
|
` stw {emit_gpr 0}, {emit_int(n - 4)}({emit_gpr 1})\n`
|
|
end else begin
|
|
if n > 0 then
|
|
` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`
|
|
end;
|
|
`{emit_label !tailrec_entry_point}:\n`;
|
|
emit_all fundecl.fun_body;
|
|
(* Emit the glue code to call the GC *)
|
|
if !call_gc_label > 0 then begin
|
|
`{emit_label !call_gc_label}:\n`;
|
|
if toc then begin
|
|
` mflr 0\n`; (* Save return address in r0 *)
|
|
` bl .caml_call_gc\n`;
|
|
` cror 31, 31, 31\n`; (* nop *)
|
|
` blr\n` (* Will re-execute the allocation *)
|
|
end else begin
|
|
` b {emit_symbol "caml_call_gc"}\n`
|
|
end
|
|
end;
|
|
(* Emit the floating-point literals *)
|
|
if !float_literals <> [] then begin
|
|
emit_string rodata_space;
|
|
` .align 3\n`;
|
|
List.iter
|
|
(fun (f, lbl) ->
|
|
`{emit_label lbl}: .double 0d{emit_string f}\n`)
|
|
!float_literals
|
|
end
|
|
|
|
(* Emission of data *)
|
|
|
|
let declare_global_data s =
|
|
` .globl {emit_symbol s}\n`;
|
|
if Config.system = "elf" then
|
|
` .type {emit_symbol s}, @object\n`
|
|
|
|
let emit_item = function
|
|
Cdefine_symbol s ->
|
|
`{emit_symbol s}:\n`;
|
|
declare_global_data s
|
|
| Cdefine_label lbl ->
|
|
`{emit_label (lbl + 100000)}:\n`
|
|
| Cint8 n ->
|
|
` .byte {emit_int n}\n`
|
|
| Cint16 n ->
|
|
` .short {emit_int n}\n`
|
|
| Cint32 n ->
|
|
` .long {emit_nativeint n}\n`
|
|
| Cint n ->
|
|
` .long {emit_nativeint n}\n`
|
|
| Csingle f ->
|
|
` .float 0d{emit_string f}\n`
|
|
| Cdouble f ->
|
|
` .double 0d{emit_string f}\n`
|
|
| Csymbol_address s ->
|
|
` .long {emit_symbol s}\n`
|
|
| Clabel_address lbl ->
|
|
` .long {emit_label (lbl + 100000)}\n`
|
|
| Cstring s ->
|
|
emit_bytes_directive " .byte " s
|
|
| Cskip n ->
|
|
if n > 0 then ` .space {emit_int n}\n`
|
|
| Calign n ->
|
|
` .align {emit_int (Misc.log2 n)}\n`
|
|
|
|
let data l =
|
|
emit_string data_space;
|
|
List.iter emit_item l
|
|
|
|
(* Beginning / end of an assembly file *)
|
|
|
|
let begin_assembly() =
|
|
Hashtbl.clear symbol_constants;
|
|
Hashtbl.clear float_constants;
|
|
defined_functions := StringSet.empty;
|
|
external_functions := StringSet.empty;
|
|
num_jumptbl_entries := 0;
|
|
jumptbl_entries := [];
|
|
lbl_jumptbl := 0;
|
|
(* Emit the beginning of the segments *)
|
|
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
|
emit_string data_space;
|
|
declare_global_data lbl_begin;
|
|
`{emit_symbol lbl_begin}:\n`;
|
|
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
|
emit_string code_space;
|
|
declare_global_data lbl_begin;
|
|
`{emit_symbol lbl_begin}:\n`
|
|
|
|
let end_assembly() =
|
|
(* Emit the jump table *)
|
|
if !num_jumptbl_entries > 0 then begin
|
|
let lbl_tbl =
|
|
if toc then begin
|
|
let lbl_tbl = new_label() in
|
|
` .toc\n`;
|
|
`{emit_label !lbl_jumptbl}: .tc {emit_label lbl_tbl}[TC], {emit_label lbl_tbl}\n`;
|
|
lbl_tbl
|
|
end else !lbl_jumptbl in
|
|
emit_string code_space;
|
|
`{emit_label lbl_tbl}:\n`;
|
|
List.iter
|
|
(fun lbl -> ` .long {emit_label lbl} - {emit_label lbl_tbl}\n`)
|
|
(List.rev !jumptbl_entries);
|
|
jumptbl_entries := []
|
|
end;
|
|
if toc then begin
|
|
(* Emit the table of constants *)
|
|
` .toc\n`;
|
|
Hashtbl.iter emit_symbol_constant symbol_constants;
|
|
Hashtbl.iter emit_float_constant float_constants
|
|
end;
|
|
if pic_externals then
|
|
(* Emit the pointers to external functions *)
|
|
StringSet.iter emit_external !external_functions;
|
|
(* Emit the end of the segments *)
|
|
emit_string code_space;
|
|
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
|
declare_global_data lbl_end;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
emit_string data_space;
|
|
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
|
declare_global_data lbl_end;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
` .long 0\n`;
|
|
(* Emit the frame descriptors *)
|
|
emit_string rodata_space;
|
|
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
|
declare_global_data lbl;
|
|
`{emit_symbol lbl}:\n`;
|
|
` .long {emit_int (List.length !frame_descriptors)}\n`;
|
|
List.iter emit_frame !frame_descriptors;
|
|
frame_descriptors := []
|