diff options
Diffstat (limited to 'ocaml-binary-annot/asmcomp/i386/emit_nt.mlp')
| -rw-r--r-- | ocaml-binary-annot/asmcomp/i386/emit_nt.mlp | 906 |
1 files changed, 906 insertions, 0 deletions
diff --git a/ocaml-binary-annot/asmcomp/i386/emit_nt.mlp b/ocaml-binary-annot/asmcomp/i386/emit_nt.mlp new file mode 100644 index 0000000000..da1606e449 --- /dev/null +++ b/ocaml-binary-annot/asmcomp/i386/emit_nt.mlp @@ -0,0 +1,906 @@ +(***********************************************************************) +(* *) +(* 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 Intel 386 assembly code, MASM syntax. *) + +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 + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = (* includes return address *) + !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + +let slot_offset loc cl = + match loc with + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> + assert (n >= 0); + n +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = + symbols_defined := StringSet.add s !symbols_defined + +let add_used_symbol s = + symbols_used := StringSet.add s !symbols_used + +let emit_symbol s = + emit_string "_"; Emitaux.emit_symbol '$' s + +let emit_int32 n = emit_printf "0%lxh" n + +(* Output a label *) + +let emit_label lbl = + emit_string "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(Incoming n | Outgoing n) } when n < 0 -> + `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + `REAL8 PTR {emit_int ofs}[esp]` + | { loc = Stack s } as r -> + let ofs = slot_offset s (register_class r) in + `DWORD PTR {emit_int ofs}[esp]` + | { loc = Unknown } -> + fatal_error "Emit.emit_reg" + +(* Output a reference to the lower 8 bits or lower 16 bits of a register *) + +let reg_low_byte_name = [| "al"; "bl"; "cl"; "dl" |] +let reg_low_half_name = [| "ax"; "bx"; "cx"; "dx"; "si"; "di"; "bp" |] + +let emit_reg8 r = + match r.loc with + Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) + | _ -> fatal_error "Emit.emit_reg8" + +let emit_reg16 r = + match r.loc with + Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) + | _ -> fatal_error "Emit.emit_reg16" + +(* 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 an addressing mode *) + +let emit_signed_int d = + if d > 0 then emit_char '+'; + if d <> 0 then emit_int d + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + add_used_symbol s; + `{emit_symbol s}{emit_signed_int d}` + | Iindexed d -> + `[{emit_reg r.(n)}{emit_signed_int d}]` + | Iindexed2 d -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` + | Iscaled(2, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` + | Iscaled(scale, d) -> + `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` + | Iindexed2scaled(scale, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` + +(* Record live pointers at call points *) + +let record_frame_label live dbg = + 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; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; + `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call _caml_ml_array_bound_error\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "add" + | Isub -> "sub" + | Imul -> "imul" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sal" + | Ilsr -> "shr" + | Iasr -> "sar" + | _ -> fatal_error "Emit: instr_for_intop" + +let instr_for_floatop = function + Inegf -> "fchs" + | Iabsf -> "fabs" + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | Ispecific Isubfrev -> "fsubr" + | Ispecific Idivfrev -> "fdivr" + | _ -> fatal_error "Emit: instr_for_floatop" + +let instr_for_floatop_reversed = function + Iaddf -> "fadd" + | Isubf -> "fsubr" + | Imulf -> "fmul" + | Idivf -> "fdivr" + | Ispecific Isubfrev -> "fsub" + | Ispecific Idivfrev -> "fdiv" + | _ -> fatal_error "Emit: instr_for_floatop_reversed" + +let instr_for_floatarithmem = function + Ifloatadd -> "fadd" + | Ifloatsub -> "fsub" + | Ifloatsubrev -> "fsubr" + | Ifloatmul -> "fmul" + | Ifloatdiv -> "fdiv" + | Ifloatdivrev -> "fdivr" + +let name_for_cond_branch = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" + | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +(* Output an = 0 or <> 0 test. *) + +let output_test_zero arg = + match arg.loc with + Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` + | _ -> ` cmp {emit_reg arg}, 0\n` + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + let n = frame_size() - 4 in + if n > 0 then ` add esp, {emit_int n}\n` + +(* Determine if the given register is the top of the floating-point stack *) + +let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false + +(* Emit the code for a floating-point comparison *) + +let emit_float_test cmp neg arg lbl = + let actual_cmp = + match (is_tos arg.(0), is_tos arg.(1)) with + (true, true) -> + (* both args on top of FP stack *) + ` fcompp\n`; + cmp + | (true, false) -> + (* first arg on top of FP stack *) + ` fcomp {emit_reg arg.(1)}\n`; + cmp + | (false, true) -> + (* second arg on top of FP stack *) + ` fcomp {emit_reg arg.(0)}\n`; + Cmm.swap_comparison cmp + | (false, false) -> + ` fld {emit_reg arg.(0)}\n`; + ` fcomp {emit_reg arg.(1)}\n`; + cmp + in + ` fnstsw ax\n`; + begin match actual_cmp with + Ceq -> + if neg then begin + ` and ah, 68\n`; + ` xor ah, 64\n`; + ` jne ` + end else begin + ` and ah, 69\n`; + ` cmp ah, 64\n`; + ` je ` + end + | Cne -> + if neg then begin + ` and ah, 69\n`; + ` cmp ah, 64\n`; + ` je ` + end else begin + ` and ah, 68\n`; + ` xor ah, 64\n`; + ` jne ` + end + | Cle -> + ` and ah, 69\n`; + ` dec ah\n`; + ` cmp ah, 64\n`; + if neg + then ` jae ` + else ` jb ` + | Cge -> + ` and ah, 5\n`; + if neg + then ` jne ` + else ` je ` + | Clt -> + ` and ah, 69\n`; + ` cmp ah, 1\n`; + if neg + then ` jne ` + else ` je ` + | Cgt -> + ` and ah, 69\n`; + if neg + then ` jne ` + else ` je ` + end; + `{emit_label lbl}\n` + +(* Emit a Ifloatspecial instruction *) + +let emit_floatspecial = function + "atan" -> ` fld1\n\tfpatan\n` + | "atan2" -> ` fpatan\n` + | "cos" -> ` fcos\n` + | "log" -> ` fldln2\n\tfxch\n\tfyl2x\n` + | "log10" -> ` fldlg2\n\tfxch\n\tfyl2x\n` + | "sin" -> ` fsin\n` + | "sqrt" -> ` fsqrt\n` + | "tan" -> ` fptan\n\tfstp st(0)\n` + | _ -> assert false + +(* 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 float_constants = ref ([] : (int * string) list) + +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 + if src.typ = Float then + if is_tos src then + ` fstp {emit_reg dst}\n` + else if is_tos dst then + ` fld {emit_reg src}\n` + else begin + ` fld {emit_reg src}\n`; + ` fstp {emit_reg dst}\n` + end + else + ` mov {emit_reg dst}, {emit_reg src}\n` + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` mov {emit_reg i.res.(0)}, 0\n` + end else + ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` + | Lop(Iconst_float s) -> + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + ` fldz\n` + | 0x8000_0000_0000_0000L -> (* -0.0 *) + ` fldz\n fchs\n` + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) + ` fld1\n` + | 0xBFF0_0000_0000_0000L -> (* -1.0 *) + ` fld1\n fchs\n` + | _ -> + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` fld {emit_label lbl}\n` + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` + | Lop(Icall_ind) -> + ` call {emit_reg i.arg.(0)}\n`; + record_frame i.live i.dbg + | Lop(Icall_imm s) -> + add_used_symbol s; + ` call {emit_symbol s}\n`; + record_frame i.live i.dbg + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` jmp {emit_label !tailrec_entry_point}\n` + else begin + output_epilogue(); + add_used_symbol s; + ` jmp {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + add_used_symbol s ; + if alloc then begin + ` mov eax, OFFSET {emit_symbol s}\n`; + ` call _caml_c_call\n`; + record_frame i.live i.dbg + end else begin + ` call {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n >= 0 + then ` sub esp, {emit_int n}\n` + else ` add esp, {emit_int(-n)}\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` mov {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Byte_unsigned -> + ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Byte_signed -> + ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_unsigned -> + ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_signed -> + ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Single -> + ` fld REAL4 PTR {emit_addressing addr i.arg 0}\n` + | Double | Double_u -> + ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` + end + | Lop(Istore(chunk, addr)) -> + begin match chunk with + | Word | Thirtytwo_signed | Thirtytwo_unsigned -> + ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` + | Byte_unsigned | Byte_signed -> + ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` + | Single -> + if is_tos i.arg.(0) then + ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` + else begin + ` fld {emit_reg i.arg.(0)}\n`; + ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` + end + | Double | Double_u -> + if is_tos i.arg.(0) then + ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` + else begin + ` fld {emit_reg i.arg.(0)}\n`; + ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` + end + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + `{emit_label lbl_redo}: mov eax, _caml_young_ptr\n`; + ` sub eax, {emit_int n}\n`; + ` mov _caml_young_ptr, eax\n`; + ` cmp eax, _caml_young_limit\n`; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live Debuginfo.none in + ` jb {emit_label lbl_call_gc}\n`; + ` lea {emit_reg i.res.(0)}, [eax+4]\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 8 -> ` call _caml_alloc1\n` + | 12 -> ` call _caml_alloc2\n` + | 16 -> ` call _caml_alloc3\n` + | _ -> ` mov eax, {emit_int n}\n`; + ` call _caml_allocN\n` + end; + `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [eax+4]\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` jbe {emit_label lbl}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` jbe {emit_label lbl}\n` + | Lop(Iintop(Idiv | Imod)) -> + ` cdq\n`; + ` idiv {emit_reg i.arg.(1)}\n` + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + ` lea {emit_reg i.res.(0)}, [{emit_reg i.arg.(0)}+{emit_int n}]\n` + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + ` inc {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + ` dec {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + let l = Misc.log2 n in + let lbl = new_label() in + output_test_zero i.arg.(0); + ` jge {emit_label lbl}\n`; + ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; + `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` + | Lop(Iintop_imm(Imod, n)) -> + let lbl = new_label() in + ` mov eax, {emit_reg i.arg.(0)}\n`; + ` test eax, eax\n`; + ` jge {emit_label lbl}\n`; + ` add eax, {emit_int(n-1)}\n`; + `{emit_label lbl}: and eax, {emit_int(-n)}\n`; + ` sub {emit_reg i.arg.(0)}, eax\n` + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Inegf | Iabsf as floatop) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) + as floatop) -> + begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with + (true, true) -> + (* both operands on top of FP stack *) + ` {emit_string(instr_for_floatop_reversed floatop)}\n` + | (true, false) -> + (* first operand on stack *) + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + | (false, true) -> + (* second operand on stack *) + ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` + | (false, false) -> + (* both operands in memory *) + ` fld {emit_reg i.arg.(0)}\n`; + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` + end + | Lop(Ifloatofint) -> + begin match i.arg.(0).loc with + Stack s -> + ` fild {emit_reg i.arg.(0)}\n` + | _ -> + ` push {emit_reg i.arg.(0)}\n`; + ` fild DWORD PTR [esp]\n`; + ` add esp, 4\n` + end + | Lop(Iintoffloat) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + stack_offset := !stack_offset - 8; + ` sub esp, 8\n`; + ` fnstcw [esp+4]\n`; + ` mov ax, [esp+4]\n`; + ` mov ah, 12\n`; + ` mov [esp], ax\n`; + ` fldcw [esp]\n`; + begin match i.res.(0).loc with + Stack s -> + ` fistp {emit_reg i.res.(0)}\n` + | _ -> + ` fistp DWORD PTR [esp]\n`; + ` mov {emit_reg i.res.(0)}, [esp]\n` + end; + ` fldcw [esp+4]\n`; + ` add esp, 8\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ilea addr)) -> + ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + add_used_symbol s ; + ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` add DWORD PTR {emit_addressing addr i.arg 0},{emit_int n}\n` + | 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 rn; typ = Float} -> + ` sub esp, 8\n`; + ` fstp REAL8 PTR 0[esp]\n`; + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 1 in + ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; + ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; + stack_offset := !stack_offset + 8 + | _ -> + ` push {emit_reg r}\n`; + stack_offset := !stack_offset + 4 + done + | Lop(Ispecific(Ipush_int n)) -> + ` push {emit_nativeint n}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_symbol s)) -> + add_used_symbol s; + ` push OFFSET {emit_symbol s}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load addr)) -> + ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load_float addr)) -> + ` push DWORD PTR {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; + ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> + if not (is_tos i.arg.(0)) then + ` fld {emit_reg i.arg.(0)}\n`; + let size = if double then "REAL8" else "REAL4" in + ` {emit_string(instr_for_floatarithmem op)} {emit_string size} PTR {emit_addressing addr i.arg 1}\n` + | Lop(Ispecific(Ifloatspecial s)) -> + (* Push args on float stack if necessary *) + for k = 0 to Array.length i.arg - 1 do + if not (is_tos i.arg.(k)) then ` fld {emit_reg i.arg.(k)}\n` + done; + (* Fix-up for binary instrs whose args were swapped *) + if Array.length i.arg = 2 && is_tos i.arg.(1) then + ` fxch st(1)\n`; + emit_floatspecial s + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` ret\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` jmp {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test_zero i.arg.(0); + ` jne {emit_label lbl}\n` + | Ifalsetest -> + output_test_zero i.arg.(0); + ` je {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + ` test {emit_reg i.arg.(0)}, 1\n`; + ` jne {emit_label lbl}\n` + | Ieventest -> + ` test {emit_reg i.arg.(0)}, 1\n`; + ` je {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` jb {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` je {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` jg {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` jmp [{emit_reg i.arg.(0)} * 4 + {emit_label lbl}]\n`; + ` .DATA\n`; + `{emit_label lbl}`; + for i = 0 to Array.length jumptbl - 1 do + ` DWORD {emit_label jumptbl.(i)}\n` + done; + ` .CODE\n` + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> + ` push _caml_exception_pointer\n`; + ` mov _caml_exception_pointer, esp\n`; + stack_offset := !stack_offset + 8 + | Lpoptrap -> + ` pop _caml_exception_pointer\n`; + ` add esp, 4\n`; + stack_offset := !stack_offset - 8 + | Lraise -> + if !Clflags.debug then begin + ` call _caml_raise_exn\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` mov esp, _caml_exception_pointer\n`; + ` pop _caml_exception_pointer\n`; + ` ret\n` + end + +let rec emit_all i = + match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next + +(* Emission of the floating-point constants *) + +let emit_float s = + (* MASM doesn't like floating-point constants such as 2e9. + Turn them into 2.0e9. *) + let pos_e = ref (-1) and pos_dot = ref (-1) in + for i = 0 to String.length s - 1 do + match s.[i] with + 'e'|'E' -> pos_e := i + | '.' -> pos_dot := i + | _ -> () + done; + if !pos_dot < 0 && !pos_e >= 0 then begin + emit_string (String.sub s 0 !pos_e); + emit_string ".0"; + emit_string (String.sub s !pos_e (String.length s - !pos_e)) + end else + emit_string s + +let emit_float_constant (lbl, cst) = + `{emit_label lbl} REAL8 {emit_float cst}\n` + +(* 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; + float_constants := []; + call_gc_sites := []; + bound_error_sites := []; + bound_error_call := 0; + ` .CODE\n`; + add_def_symbol fundecl.fun_name; + emit_align 4; + ` PUBLIC {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() - 4 in + if n > 0 then + ` sub esp, {emit_int n}\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + emit_call_bound_errors (); + begin match !float_constants with + [] -> () + | _ -> + ` .DATA\n`; + List.iter emit_float_constant !float_constants; + float_constants := [] + end + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` PUBLIC {emit_symbol s}\n`; + | Cdefine_symbol s -> + add_def_symbol s ; + `{emit_symbol s} LABEL DWORD\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)} ` + | Cint8 n -> + ` BYTE {emit_int n}\n` + | Cint16 n -> + ` WORD {emit_int n}\n` + | Cint n -> + ` DWORD {emit_nativeint n}\n` + | Cint32 n -> + ` DWORD {emit_nativeint n}\n` + | Csingle f -> + ` REAL4 {emit_float f}\n` + | Cdouble f -> + ` REAL8 {emit_float f}\n` + | Csymbol_address s -> + add_used_symbol s ; + ` DWORD {emit_symbol s}\n` + | Clabel_address lbl -> + ` DWORD {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_bytes_directive " BYTE " s + | Cskip n -> + if n > 0 then ` BYTE {emit_int n} DUP (?)\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() = + `.386\n`; + ` .MODEL FLAT\n\n`; + ` EXTERN _caml_young_ptr: DWORD\n`; + ` EXTERN _caml_young_limit: DWORD\n`; + ` EXTERN _caml_exception_pointer: DWORD\n`; + ` EXTERN _caml_extra_params: DWORD\n`; + ` EXTERN _caml_call_gc: PROC\n`; + ` EXTERN _caml_c_call: PROC\n`; + ` EXTERN _caml_allocN: PROC\n`; + ` EXTERN _caml_alloc1: PROC\n`; + ` EXTERN _caml_alloc2: PROC\n`; + ` EXTERN _caml_alloc3: PROC\n`; + ` EXTERN _caml_ml_array_bound_error: PROC\n`; + ` EXTERN _caml_raise_exn: PROC\n`; + ` .DATA\n`; + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + add_def_symbol lbl_begin; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL DWORD\n`; + ` .CODE\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + add_def_symbol lbl_begin; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL DWORD\n` + +let end_assembly() = + ` .CODE\n`; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + add_def_symbol lbl_end; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL DWORD\n`; + ` .DATA\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + add_def_symbol lbl_end; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL DWORD\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + add_def_symbol lbl; + ` PUBLIC {emit_symbol lbl}\n`; + `{emit_symbol lbl}`; + emit_frames + { efa_label = (fun l -> ` DWORD {emit_label l}\n`); + efa_16 = (fun n -> ` WORD {emit_int n}\n`); + efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); + efa_word = (fun n -> ` DWORD {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l} LABEL DWORD\n`); + efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; + `\n;External functions\n\n`; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + ` EXTERN {emit_symbol s}: PROC\n`) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + `END\n` |