diff options
Diffstat (limited to 'ocaml-binary-annot/asmcomp/hppa/emit.mlp')
| -rw-r--r-- | ocaml-binary-annot/asmcomp/hppa/emit.mlp | 1042 |
1 files changed, 1042 insertions, 0 deletions
diff --git a/ocaml-binary-annot/asmcomp/hppa/emit.mlp b/ocaml-binary-annot/asmcomp/hppa/emit.mlp new file mode 100644 index 0000000000..b697a335a2 --- /dev/null +++ b/ocaml-binary-annot/asmcomp/hppa/emit.mlp @@ -0,0 +1,1042 @@ +(***********************************************************************) +(* *) +(* 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 HP PA-RISC assembly code *) + +(* Must come before open Reg... *) +module StringSet = + Set.Make(struct + type t = string + let compare = compare + end) + +open Location +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 + +(* Layout of the stack *) +(* Always keep the stack 8-aligned. *) + +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 + | Local n -> + if cl = 0 + then - !stack_offset - num_stack_slots.(1) * 8 - n * 4 - 4 + else - !stack_offset - n * 8 - 8 + | Outgoing n -> -n + +(* 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) + | _ -> assert false + +(* Output low address / high address prefixes *) + +let low_prefix = "RR%" +let high_prefix = "LR%" + +let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) + +let emit_int_low n = emit_string low_prefix; emit_int n +let emit_int_high n = emit_string high_prefix; emit_int n + +let emit_nativeint_low n = emit_string low_prefix; emit_nativeint n +let emit_nativeint_high n = emit_string high_prefix; emit_nativeint n + +let emit_symbol_low s = + `RR%{emit_symbol s}-$global$` + +let load_symbol_high s = + ` addil LR%{emit_symbol s}-$global$, %r27\n` + +let load_symbol_offset_high s ofs = + ` addil LR%{emit_symbol s}-$global$+{emit_int ofs}, %r27\n` + +(* Record imported and defined symbols *) + +let used_symbols = ref StringSet.empty +let defined_symbols = ref StringSet.empty +let called_symbols = ref StringSet.empty + +let use_symbol s = + used_symbols := StringSet.add s !used_symbols +let define_symbol s = + defined_symbols := StringSet.add s !defined_symbols +let call_symbol s = + used_symbols := StringSet.add s !used_symbols; + called_symbols := StringSet.add s !called_symbols + +(* An external symbol is code if either it is branched to, or + it is one of the caml_apply* caml_curry* caml_tuplify* special functions. *) + +let code_imports = ["caml_apply"; "caml_curry"; "caml_tuplify"] + +let match_prefix s pref = + String.length s >= String.length pref + && String.sub s 0 (String.length pref) = pref + +let emit_import s = + if not(StringSet.mem s !defined_symbols) then begin + ` .import {emit_symbol s}`; + if StringSet.mem s !called_symbols + || List.exists (match_prefix s) code_imports + then `, code\n` + else `, data\n` + end + +let emit_imports () = + StringSet.iter emit_import !used_symbols; + used_symbols := StringSet.empty; + defined_symbols := StringSet.empty; + called_symbols := StringSet.empty + +(* Output an integer load / store *) + +let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *) + +let is_offset_native n = + n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192) + +let emit_load instr addr arg dst = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` {emit_string instr} {emit_symbol_low s}(%r1), {emit_reg dst}\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` {emit_string instr} {emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n` + | Iindexed ofs -> + if is_offset ofs then + ` {emit_string instr} {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` {emit_string instr} {emit_int_low ofs}(%r1), {emit_reg dst}\n` + end + +let emit_store instr addr arg src = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}(%r1)\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}+{emit_int ofs}(%r1)\n` + | Iindexed ofs -> + if is_offset ofs then + ` {emit_string instr} {emit_reg src}, {emit_int ofs}({emit_reg arg.(1)})\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` {emit_string instr} {emit_reg src}, {emit_int_low ofs}(%r1)\n` + end + +(* Output a floating-point load / store *) + +let emit_float_load addr arg dst doubleword = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), %r1\n`; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + | Iindexed ofs -> + if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) + then begin + ` fldws {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}L\n`; + if doubleword then + ` fldws {emit_int (ofs+4)}({emit_reg arg.(0)}), {emit_reg dst}R\n` + end else begin + if is_offset ofs then + ` ldo {emit_int ofs}({emit_reg arg.(0)}), %r1\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; + ` ldo {emit_int_low ofs}(%r1), %r1\n` + end; + ` fldws 0(%r1), {emit_reg dst}L\n`; + if doubleword then + ` fldws 4(%r1), {emit_reg dst}R\n` + end + +let emit_float_store addr arg src doubleword = + match addr with + Ibased(s, 0) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), %r1\n`; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + | Ibased(s, ofs) -> + use_symbol s; + load_symbol_offset_high s ofs; + ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + | Iindexed ofs -> + if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) + then begin + ` fstws {emit_reg src}L, {emit_int ofs}({emit_reg arg.(1)})\n`; + if doubleword then + ` fstws {emit_reg src}R, {emit_int(ofs+4)}({emit_reg arg.(1)})\n` + end else begin + if is_offset ofs then + ` ldo {emit_int ofs}({emit_reg arg.(1)}), %r1\n` + else begin + ` addil {emit_int_high ofs}, {emit_reg arg.(1)}\n`; + ` ldo {emit_int_low ofs}(%r1), %r1\n` + end; + ` fstws {emit_reg src}L, 0(%r1)\n`; + if doubleword then + ` fstws {emit_reg src}R, 4(%r1)\n` + end + +(* Output an align directive. *) + +let emit_align n = + ` .align {emit_int n}\n` + +(* 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}:\n` + +let emit_frame fd = + ` .long {emit_label fd.fd_lbl} + 3\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; + emit_align 4 + +(* Record floating-point constants *) + +let float_constants = ref ([] : (int * string) list) + +let emit_float_constants () = + if Config.system = "hpux" then begin + ` .space $TEXT$\n`; + ` .subspa $LIT$\n` + end else + ` .text\n`; + emit_align 8; + List.iter + (fun (lbl, cst) -> + `{emit_label lbl}:`; + emit_float64_split_directive ".long" cst) + !float_constants; + float_constants := [] + +(* Describe the registers used to pass arguments to a C function *) + +let describe_call arg = + ` .CALL RTNVAL=NO`; + let pos = ref 0 in + for i = 0 to Array.length arg - 1 do + if !pos < 4 then begin + match arg.(i).typ with + Float -> `, ARGW{emit_int !pos}=FR, ARGW{emit_int(!pos + 1)}=FU`; + pos := !pos + 2 + | _ -> `, ARGW{emit_int !pos}=GR`; + pos := !pos + 1 + end + done; + `\n` + +(* Output a function call *) + +let emit_call s retreg = + call_symbol s; + ` bl {emit_symbol s}, {emit_string retreg}\n` + +(* Names of various instructions *) + +let name_for_int_operation = function + Iadd -> "add" + | Isub -> "sub" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | _ -> assert false + +let name_for_float_operation = function + Iaddf -> "fadd,dbl" + | Isubf -> "fsub,dbl" + | Imulf -> "fmpy,dbl" + | Idivf -> "fdiv,dbl" + | _ -> assert false + +let name_for_specific_operation = function + Ishift1add -> "sh1add" + | Ishift2add -> "sh2add" + | Ishift3add -> "sh3add" + +let name_for_int_comparison = function + Isigned Ceq -> "=" | Isigned Cne -> "<>" + | Isigned Cle -> "<=" | Isigned Cgt -> ">" + | Isigned Clt -> "<" | Isigned Cge -> ">=" + | Iunsigned Ceq -> "=" | Iunsigned Cne -> "<>" + | Iunsigned Cle -> "<<=" | Iunsigned Cgt -> ">>" + | Iunsigned Clt -> "<<" | Iunsigned Cge -> ">>=" + +let name_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then "=" else "!=" + | Cne -> if neg then "!=" else "=" + | Cle -> if neg then "<=" else "!<=" + | Cgt -> if neg then ">" else "!>" + | Clt -> if neg then "<" else "!<" + | Cge -> if neg then ">=" else "!>=" + +let negate_int_comparison = function + Isigned cmp -> Isigned(Cmm.negate_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) + +let swap_int_comparison = function + Isigned cmp -> Isigned(Cmm.swap_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.swap_comparison cmp) + + +(* 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 rec emit_instr i dslot = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + begin match (src, dst) with + {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + ` copy {emit_reg src}, {emit_reg dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` fcpy,dbl {emit_reg src}, {emit_reg dst}\n` + | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + let ofs = slot_offset sd 0 in + ` stw {emit_reg src}, {emit_int ofs}(%r30)\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + let ofs = slot_offset sd 1 in + if is_immediate ofs then + ` fstds {emit_reg src}, {emit_int ofs}(%r30)\n` + else begin + ` ldo {emit_int ofs}(%r30), %r1\n`; + ` fstds {emit_reg src}, 0(%r1)\n` + end + | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + let ofs = slot_offset ss 0 in + ` ldw {emit_int ofs}(%r30), {emit_reg dst}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + let ofs = slot_offset ss 1 in + if is_immediate ofs then + ` fldds {emit_int ofs}(%r30), {emit_reg dst}\n` + else begin + ` ldo {emit_int ofs}(%r30), %r1\n`; + ` fldds 0(%r1), {emit_reg dst}\n` + end + | (_, _) -> + assert false + end + | Lop(Iconst_int n) -> + if is_offset_native n then + ` ldi {emit_nativeint n}, {emit_reg i.res.(0)}\n` + else begin + ` ldil {emit_nativeint_high n}, {emit_reg i.res.(0)}\n`; + ` ldo {emit_nativeint_low n}({emit_reg i.res.(0)}), {emit_reg i.res.(0)}\n` + end + | Lop(Iconst_float s) -> + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` ldil {emit_string high_prefix}{emit_label lbl}, %r1\n`; + ` ldo {emit_string low_prefix}{emit_label lbl}(%r1), %r1\n`; + ` fldds 0(%r1), {emit_reg i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + use_symbol s; + load_symbol_high s; + ` ldo {emit_symbol_low s}(%r1), {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + ` ble 0(4, {emit_reg i.arg.(0)})\n`; (* retaddr in %r31 *) + ` copy %r31, %r2\n`; (* in delay slot: save retaddr in %r2 *) + record_frame i.live + | Lop(Icall_imm s) -> + emit_call s "%r2"; + fill_delay_slot dslot; + record_frame i.live + | Lop(Itailcall_ind) -> + let n = frame_size() in + ` bv 0({emit_reg i.arg.(0)})\n`; + if !contains_calls (* in delay slot *) + then ` ldwm {emit_int(-n)}(%r30), %r2\n` + else ` ldo {emit_int(-n)}(%r30), %r30\n` + | Lop(Itailcall_imm s) -> + let n = frame_size() in + if s = !function_name then begin + ` b,n {emit_label !tailrec_entry_point}\n` + end else begin + emit_call s "%r0"; + if !contains_calls (* in delay slot *) + then ` ldwm {emit_int(-n)}(%r30), %r2\n` + else ` ldo {emit_int(-n)}(%r30), %r30\n` + end + | Lop(Iextcall(s, alloc)) -> + call_symbol s; + if alloc then begin + ` ldil LR%{emit_symbol s}, %r22\n`; + describe_call i.arg; + emit_call "caml_c_call" "%r2"; + ` ldo RR%{emit_symbol s}(%r22), %r22\n`; (* in delay slot *) + record_frame i.live + end else begin + describe_call i.arg; + emit_call s "%r2"; + fill_delay_slot dslot + end + | Lop(Istackoffset n) -> + ` ldo {emit_int n}(%r30), %r30\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + Byte_unsigned -> + emit_load "ldb" addr i.arg dest + | Byte_signed -> + emit_load "ldb" addr i.arg dest; + ` extrs {emit_reg dest}, 31, 8, {emit_reg dest}\n` + | Sixteen_unsigned -> + emit_load "ldh" addr i.arg dest + | Sixteen_signed -> + emit_load "ldh" addr i.arg dest; + ` extrs {emit_reg dest}, 31, 16, {emit_reg dest}\n` + | Single -> + emit_float_load addr i.arg dest false; + ` fcnvff,sgl,dbl {emit_reg dest}L, {emit_reg dest}\n` + | Double | Double_u -> + emit_float_load addr i.arg dest true + | _ -> + emit_load "ldw" addr i.arg dest + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + begin match chunk with + Byte_unsigned | Byte_signed -> + emit_store "stb" addr i.arg src + | Sixteen_unsigned | Sixteen_signed -> + emit_store "sth" addr i.arg src + | Single -> + ` fcnvff,dbl,sgl {emit_reg src}, %fr31L\n`; + emit_float_store addr i.arg (phys_reg 127) (* %fr31 *) false + | Double | Double_u -> + emit_float_store addr i.arg src true + | _ -> + emit_store "stw" addr i.arg src + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_cont = new_label() in + ` ldw 0(%r4), %r1\n`; + ` ldo {emit_int (-n)}(%r3), %r3\n`; + ` comb,>>= %r3, %r1, {emit_label lbl_cont}\n`; + ` addi 4, %r3, {emit_reg i.res.(0)}\n`; (* in delay slot *) + emit_call "caml_call_gc" "%r2"; + (* Cannot use %r1 to pass size, since clobbered by glue call code *) + ` ldi {emit_int n}, %r29\n`; (* in delay slot *) + record_frame i.live; + ` addi 4, %r3, {emit_reg i.res.(0)}\n`; + `{emit_label lbl_cont}:\n` + end else begin + emit_call "caml_allocN" "%r2"; + (* Cannot use %r1 either *) + ` ldi {emit_int n}, %r29\n`; (* in delay slot *) + record_frame i.live; + ` addi 4, %r3, {emit_reg i.res.(0)}\n` + end + | Lop(Iintop Imul) -> + ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; + ` stw {emit_reg i.arg.(1)}, -4(%r30)\n`; + ` fldws -8(%r30), %fr31L\n`; + ` fldws -4(%r30), %fr31R\n`; + ` xmpyu %fr31L, %fr31R, %fr31\n`; + ` fstws %fr31R, -8(%r30)\n`; (* poor scheduling *) + ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` + | Lop(Iintop Idiv) -> + (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) + ` bl $$divI, %r31\n`; + fill_delay_slot dslot + | Lop(Iintop Imod) -> + (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) + ` bl $$remI, %r31\n`; + fill_delay_slot dslot + | Lop(Iintop Ilsl) -> + ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; + ` mtsar %r1\n`; + ` zvdep {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` + | Lop(Iintop Ilsr) -> + ` mtsar {emit_reg i.arg.(1)}\n`; + ` vshd %r0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop Iasr) -> + ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; + ` mtsar %r1\n`; + ` vextrs {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` + | Lop(Iintop(Icomp cmp)) -> + let comp = name_for_int_comparison(negate_int_comparison cmp) in + ` comclr,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; + ` ldi 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` comclr,>> {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %r0\n`; + ` b,n {emit_label !range_check_trap}\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(Iadd, n)) -> + ` addi {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Isub, n)) -> + ` addi {emit_int(-n)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; + if not (l = 0) then + ` zdepi -1, 31, {emit_int l}, %r1\n` + else + ` xor %r1, %r1, %r1\n`; + ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; + ` extrs %r1, {emit_int(31-l)}, {emit_int(32-l)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Imod, n)) -> + let l = Misc.log2 n in + ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; + if not (l = 0) then + ` zdepi -1, 31, {emit_int l}, %r1\n` + else + ` xor %r1, %r1, %r1\n`; + ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; + ` depi 0, 31, {emit_int l}, %r1\n`; + ` sub {emit_reg i.arg.(0)}, %r1, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Ilsl, n)) -> + let n = n land 31 in + ` zdep {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Ilsr, n)) -> + let n = n land 31 in + ` extru {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iasr, n)) -> + let n = n land 31 in + ` extrs {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + let comp = name_for_int_comparison(negate_int_comparison(swap_int_comparison cmp)) in + ` comiclr,{emit_string comp} {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; + ` ldi 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` comiclr,<< {emit_int n}, {emit_reg i.arg.(0)}, %r0\n`; + ` b,n {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(op, n)) -> + assert false + | 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(Inegf) -> + ` fsub,dbl 0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iabsf) -> + ` fabs,dbl {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; + ` fldws,mb -8(%r30), %fr31L\n`; + ` fcnvxf,sgl,dbl %fr31L, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` fcnvfxt,dbl,sgl {emit_reg i.arg.(0)}, %fr31L\n`; + ` fstws,ma %fr31L, 8(%r30)\n`; + ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` + | Lop(Ispecific sop) -> + let instr = name_for_specific_operation sop in + ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` ldw {emit_int(-n)}(%r30), %r2\n` + | Lreturn -> + let n = frame_size() in + ` bv 0(%r2)\n`; + ` ldo {emit_int(-n)}(%r30), %r30\n` (* in delay slot *) + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + begin match dslot with + None -> + ` b,n {emit_label lbl}\n` + | Some i -> + ` b {emit_label lbl}\n`; + emit_instr i None + end + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + emit_comib "<>" "=" 0 i.arg lbl dslot + | Ifalsetest -> + emit_comib "=" "<>" 0 i.arg lbl dslot + | Iinttest cmp -> + let comp = name_for_int_comparison cmp + and negcomp = + name_for_int_comparison(negate_int_comparison cmp) in + emit_comb comp negcomp i.arg lbl dslot + | Iinttest_imm(cmp, n) -> + let scmp = swap_int_comparison cmp in + let comp = name_for_int_comparison scmp + and negcomp = + name_for_int_comparison(negate_int_comparison scmp) in + emit_comib comp negcomp n i.arg lbl dslot + | Ifloattest(cmp, neg) -> + let comp = name_for_float_comparison cmp neg in + ` fcmp,dbl,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` ftest\n`; + ` b {emit_label lbl}\n`; + fill_delay_slot dslot + | Ioddtest -> + emit_comib "OD" "EV" 0 i.arg lbl dslot + | Ieventest -> + emit_comib "EV" "OD" 0 i.arg lbl dslot + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + begin match lbl0 with + None -> () + | Some lbl -> emit_comib "=" "<>" 0 i.arg lbl None + end; + begin match lbl1 with + None -> () + | Some lbl -> emit_comib "=" "<>" 1 i.arg lbl None + end; + begin match lbl2 with + None -> () + | Some lbl -> emit_comib "=" "<>" 2 i.arg lbl None + end + | Lswitch jumptbl -> + ` blr {emit_reg i.arg.(0)}, 0\n`; + fill_delay_slot dslot; + for i = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(i)}\n`; + ` nop\n` + done + | Lsetuptrap lbl -> + ` bl {emit_label lbl}, %r1\n`; + fill_delay_slot dslot + | Lpushtrap -> + stack_offset := !stack_offset + 8; + ` stws,ma %r5, 8(%r30)\n`; + ` stw %r1, -4(%r30)\n`; + ` copy %r30, %r5\n` + | Lpoptrap -> + ` ldws,mb -8(%r30), %r5\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + ` ldw -4(%r5), %r1\n`; + ` copy %r5, %r30\n`; + ` bv 0(%r1)\n`; + ` ldws,mb -8(%r30), %r5\n` (* in delay slot *) + +and fill_delay_slot = function + None -> ` nop\n` + | Some i -> emit_instr i None + +and emit_delay_slot = function + None -> () + | Some i -> emit_instr i None + +and emit_comb comp negcomp arg lbl dslot = + if lbl >= 0 then begin + ` comb,{emit_string comp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, {emit_label lbl}\n`; + fill_delay_slot dslot + end else begin + emit_delay_slot dslot; + ` comclr,{emit_string negcomp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, %r0\n`; + ` b,n {emit_label (-lbl)}\n` + end + +and emit_comib comp negcomp cst arg lbl dslot = + if lbl >= 0 then begin + ` comib,{emit_string comp} {emit_int cst}, {emit_reg arg.(0)}, {emit_label lbl}\n`; + fill_delay_slot dslot + end else begin + emit_delay_slot dslot; + ` comiclr,{emit_string negcomp} {emit_int cst}, {emit_reg arg.(0)}, %r0\n`; + ` b,n {emit_label (-lbl)}\n` + end + +(* Checks if a pseudo-instruction expands to exactly one machine instruction + that does not branch. *) + +let is_one_instr i = + match i.desc with + Lop op -> + begin match op with + Imove | Ispill | Ireload -> + begin match (i.arg.(0), i.res.(0)) with + ({typ = Float; loc = Stack s}, _) -> is_immediate(slot_offset s 1) + | (_, {typ = Float; loc = Stack s}) -> is_immediate(slot_offset s 1) + | (_, _) -> true + end + | Iconst_int n -> is_offset_native n + | Istackoffset _ -> true + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_offset n + | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_offset n + | Iintop(Iadd | Isub | Iand | Ior | Ixor) -> true + | Iintop_imm((Iadd | Isub | Ilsl | Ilsr | Iasr), _) -> true + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf -> true + | Ispecific _ -> true + | _ -> false + 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 = Lop(Icall_imm _) + | Lop(Iextcall(_, false)) + | Lop(Iintop(Idiv | Imod)) + | Lbranch _ + | Lsetuptrap _ }} + when is_one_instr i -> + emit_instr i.next (Some i); + emit_all i.next.next + | {next = {desc = Lcondbranch(_, _) | Lswitch _}} + 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 + +(* Estimate the size of an instruction, in actual HPPA instructions *) + +let is_float_stack r = + match r with {loc = Stack _; typ = Float} -> true | _ -> false + +let sizeof_instr i = + match i.desc with + Lend -> 0 + | Lop op -> + begin match op with + Imove | Ispill | Ireload -> + if is_float_stack i.arg.(0) || is_float_stack i.res.(0) + then 2 (* ldo/fxxx *) else 1 + | Iconst_int n -> + if is_offset_native n then 1 else 2 (* ldi or ldil/ldo *) + | Iconst_float _ -> 3 (* ldil/ldo/fldds *) + | Iconst_symbol _ -> 2 (* addil/ldo *) + | Icall_ind -> 2 (* ble/copy *) + | Icall_imm _ -> 2 (* bl/nop *) + | Itailcall_ind -> 2 (* bv/ldwm *) + | Itailcall_imm _ -> 2 (* bl/ldwm *) + | Iextcall(_, alloc) -> + if alloc then 3 (* ldil/bl/ldo *) else 2 (* bl/nop *) + | Istackoffset _ -> 1 (* ldo *) + | Iload(chunk, addr) -> + if i.res.(0).typ = Float + then 4 (* addil/ldo/fldws/fldws *) + else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) + + (match chunk with Byte_signed -> 1 | Sixteen_signed -> 1 | _ -> 0) + | Istore(chunk, addr) -> + if i.arg.(0).typ = Float + then 4 (* addil/ldo/fstws/fstws *) + else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) + | Ialloc _ -> if !fastcode_flag then 7 else 3 + | Iintop Imul -> 7 + | Iintop(Idiv | Imod) -> 3 (* ldil/ble/nop *) + | Iintop Ilsl -> 3 (* subi/mtsar/zvdep *) + | Iintop Ilsr -> 2 (* mtsar/vshd *) + | Iintop Iasr -> 3 (* subi/mtsar/vextrs *) + | Iintop(Icomp _) -> 2 (* comclr/ldi *) + | Iintop Icheckbound -> 2 (* comclr/b,n *) + | Iintop _ -> 1 + | Iintop_imm(Idiv, _) -> 4 (* comclr/zdepi/add/extrs *) + | Iintop_imm(Imod, _) -> 5 (* comclr/zdepi/add/extrs/sub *) + | Iintop_imm(Icomp _, _) -> 2 (* comiclr/ldi *) + | Iintop_imm(Icheckbound, _) -> 2 (* comiclr/b,n *) + | Iintop_imm(_, _) -> 1 + | Ifloatofint -> 3 (* stws,ma/fldws,mb/fcnvxf *) + | Iintoffloat -> 3 (* fcnfxt/fstws/ldws *) + | _ (* Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ispecific _ *) -> 1 + end + | Lreloadretaddr -> 1 + | Lreturn -> 2 + | Llabel _ -> 0 + | Lbranch _ -> 1 (* b,n *) + | Lcondbranch(Ifloattest(_, _), _) -> 4 (* fcmp/ftest/b/nop *) + | Lcondbranch(_, _) -> 2 (* comb/nop or comclr/b,n *) + | Lcondbranch3(_, _, _) -> 6 (* worst case: three comib/nop or comclr/b,n *) + | Lswitch tbl -> 2 + 2 * Array.length tbl (* blr/nop b/nop *) + | Lsetuptrap _ -> 2 (* bl/nop *) + | Lpushtrap -> 3 (* stws,ma/stw/copy *) + | Lpoptrap -> 1 (* ldws,mb *) + | Lraise -> 4 (* ldw/copy/bv/ldws,mb *) + +(* Estimate the position of all labels in function body + and rewrite long conditional branches with a negative label. *) + +let fixup_cond_branches funbody = + let label_position = + (Hashtbl.create 87 : (label, int) Hashtbl.t) in + let rec estimate_labels pos i = + match i.desc with + Lend -> () + | Llabel lbl -> + Hashtbl.add label_position lbl pos; estimate_labels pos i.next + | _ -> estimate_labels (pos + sizeof_instr i) i.next in + let long_branch currpos lbl = + try + let displ = Hashtbl.find label_position lbl - currpos in + (* Branch offset is stored in 12 bits, giving a range of + -2048 to +2047. Here, we allow 10% error in estimating + the code positions. *) + displ < -1843 || displ > 1842 + with Not_found -> + assert false in + let rec fix_branches pos i = + match i.desc with + Lend -> () + | Lcondbranch(tst, lbl) -> + if long_branch pos lbl then i.desc <- Lcondbranch(tst, -lbl); + fix_branches (pos + sizeof_instr i) i.next + | Lcondbranch3(opt1, opt2, opt3) -> + let fix_opt = function + None -> None + | Some lbl -> Some(if long_branch pos lbl then -lbl else lbl) in + i.desc <- Lcondbranch3(fix_opt opt1, fix_opt opt2, fix_opt opt3); + fix_branches (pos + sizeof_instr i) i.next + | _ -> + fix_branches (pos + sizeof_instr i) i.next in + estimate_labels 0 funbody; + fix_branches 0 funbody + +(* Emission of a function declaration *) + +let fundecl fundecl = + fixup_cond_branches fundecl.fun_body; + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + define_symbol fundecl.fun_name; + range_check_trap := 0; + let n = frame_size() in + begin match Config.system with + | "hpux" -> + ` .code\n`; + ` .align 4\n`; + ` .export {emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`; + `{emit_symbol fundecl.fun_name}:\n`; + ` .proc\n`; + if !contains_calls then + ` .callinfo frame={emit_int n}, calls, save_rp\n` + else + ` .callinfo frame={emit_int n}, no_calls\n`; + ` .entry\n` + | "linux" | "gnu" -> + ` .text\n`; + ` .align 8\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n` + | _ -> + assert false + end; + if !contains_calls then + ` stwm %r2, {emit_int n}(%r30)\n` + else if n > 0 then + ` ldo {emit_int n}(%r30), %r30\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`; + emit_call "caml_ml_array_bound_error" "%r31"; + ` nop\n` + end; + if Config.system = "hpux"then begin + ` .exit\n`; + ` .procend\n` + end; + emit_float_constants() + +(* Emission of data *) + +let declare_global s = + define_symbol s; + if Config.system = "hpux" + then ` .export {emit_symbol s}, data\n` + else ` .globl {emit_symbol s}\n` + +let emit_item = function + Cglobal_symbol s -> + declare_global s + | Cdefine_symbol s -> + define_symbol s; + `{emit_symbol s}:\n` + | 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 -> + emit_float32_directive ".long" f + | Cdouble f -> + emit_float64_split_directive ".long" f + | Csymbol_address s -> + use_symbol s; + ` .long {emit_symbol s}\n` + | Clabel_address lbl -> + ` .long {emit_label(lbl + 100000)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then + if Config.system = "hpux" + then ` .block {emit_int n}\n` + else ` .space {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() = + if Config.system = "hpux" then begin + ` .space $PRIVATE$\n`; + ` .subspa $DATA$,quad=1,align=8,access=31\n`; + ` .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82\n`; + ` .space $TEXT$\n`; + ` .subspa $LIT$,quad=0,align=8,access=44\n`; + ` .subspa $CODE$,quad=0,align=8,access=44,code_only\n`; + ` .import $global$, data\n`; + ` .import $$divI, millicode\n`; + ` .import $$remI, millicode\n` + end; + used_symbols := StringSet.empty; + defined_symbols := StringSet.empty; + called_symbols := StringSet.empty; + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + ` .data\n`; + declare_global lbl_begin; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + ` .code\n`; + declare_global lbl_begin; + `{emit_symbol lbl_begin}:\n` + + +let end_assembly() = + ` .code\n`; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + declare_global lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .data\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + declare_global lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + declare_global lbl; + `{emit_symbol lbl}:\n`; + ` .long {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := []; + emit_imports() |