diff options
34 files changed, 11 insertions, 7863 deletions
@@ -41,6 +41,7 @@ Feature wishes: - PR#5420: Unix.openfile share mode (Windows) Shedding weight: +- Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. - The "DBM" library (interface with Unix DBM key-value stores) is no longer part of this distribution. It now lives its own life at https://forge.ocamlcore.org/projects/camldbm/ @@ -23,19 +23,15 @@ Tier 1 (actively used and maintained by the core Caml team): AMD64 (Opteron) Linux, MacOS X, MS Windows IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows - PowerPC MacOS X + PowerPC Linux, MacOS X + ARM Linux Tier 2 (maintained when possible, with help from users): - Alpha Digital Unix/Compaq Tru64, Linux, all BSD AMD64 FreeBSD, OpenBSD - HP PA-RISC HPUX 11, Linux IA32 (Pentium) NetBSD, OpenBSD, Solaris 9 - IA64 Linux, FreeBSD - MIPS IRIX 6 - PowerPC Linux, NetBSD - SPARC Solaris 9, Linux, NetBSD - Strong ARM Linux + PowerPC NetBSD + SPARC Solaris, Linux, NetBSD Other operating systems for the processors above have not been tested, but the compiler may work under other operating systems with little work. @@ -79,8 +75,9 @@ COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -2007, 2008 Institut National de Recherche en Informatique et en Automatique -(INRIA) and distributed under the conditions stated in file LICENSE. +2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en +Informatique et en Automatique (INRIA) and distributed under the +conditions stated in file LICENSE. INSTALLATION: @@ -106,7 +103,7 @@ There exists a mailing list of users of the Caml implementations developed at INRIA. The purpose of this list is to share experience, exchange ideas (and even code), and report on applications of the Caml language. Messages can be written in English or in -French. The list has about 750 subscribers. +French. The list has more than 1000 subscribers. Messages to the list should be sent to: @@ -114,9 +111,9 @@ Messages to the list should be sent to: You can subscribe to this list via the Web interface at - http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-list + https://sympa-roc.inria.fr/wws/info/caml-list -Archives of the list are available on the Web site http://caml.inria.fr/ +Archives of the list are available on the Web site above. The Usenet news groups comp.lang.ml and comp.lang.functional also contains discussions about the ML family of programming languages, diff --git a/asmcomp/alpha/arch.ml b/asmcomp/alpha/arch.ml deleted file mode 100644 index 76574d66f..000000000 --- a/asmcomp/alpha/arch.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Specific operations for the Alpha processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Specific operations *) - -type specific_operation = - Iadd4 | Iadd8 | Isub4 | Isub8 (* Scaled adds and subs *) - | Ireloadgp of bool (* The ldgp instruction *) - | Itrunc32 (* Truncate 64-bit int to 32 bit *) - -(* Sizes, endianness *) - -let big_endian = false - -let size_addr = 8 -let size_int = 8 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - fprintf ppf "\"%s\"%s" s - (if n <> 0 then Printf.sprintf " + %i" n else "") - | Iindexed n -> - fprintf ppf "%a%s" printreg arg.(0) - (if n <> 0 then Printf.sprintf " + %i" n else "") - -let print_specific_operation printreg op ppf arg = - match op with - | Iadd4 -> fprintf ppf "%a * 4 + %a" printreg arg.(0) printreg arg.(1) - | Iadd8 -> fprintf ppf "%a * 8 + %a" printreg arg.(0) printreg arg.(1) - | Isub4 -> fprintf ppf "%a * 4 - %a" printreg arg.(0) printreg arg.(1) - | Isub8 -> fprintf ppf "%a * 8 - %a" printreg arg.(0) printreg arg.(1) - | Ireloadgp _ -> fprintf ppf "ldgp" - | Itrunc32 -> fprintf ppf "truncate32 %a" printreg arg.(0) - -(* Distinguish between the Digital assembler and other assemblers (e.g. gas) *) - -let digital_asm = - match Config.system with - "digital" -> true - | _ -> false diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp deleted file mode 100644 index c596e989b..000000000 --- a/asmcomp/alpha/emit.mlp +++ /dev/null @@ -1,861 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -module LabelSet = - Set.Make(struct type t = Linearize.label let compare = compare end) - -(* Emission of Alpha assembly code *) - -open Location -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* First pass: insert Iloadgp instructions where needed *) - -let insert_load_gp f = - - let labels_needing_gp = ref LabelSet.empty in - let fixpoint_reached = ref false in - - let label_needs_gp lbl = - LabelSet.mem lbl !labels_needing_gp in - let opt_label_needs_gp default = function - None -> default - | Some lbl -> label_needs_gp lbl in - let set_label_needs_gp lbl = - if not (label_needs_gp lbl) then begin - fixpoint_reached := false; - labels_needing_gp := LabelSet.add lbl !labels_needing_gp - end in - - let tailrec_entry_point = new_label() in - - (* Determine if $gp is needed before an instruction. - [next] says whether $gp is needed just after (i.e. by the following - instruction). *) - let instr_needs_gp next = function - Lend -> false - | Lop(Iconst_int n) -> (* for large n, turned into ldq ($gp) *) - next || n < Nativeint.of_int(-0x80000000) - || n > Nativeint.of_int 0x7FFFFFFF - | Lop(Iconst_float s) -> true (* turned into ldq ($gp) *) - | Lop(Iconst_symbol s) -> true (* turned into ldq ($gp) *) - | Lop(Icall_ind) -> false (* does ldgp if needed afterwards *) - | Lop(Icall_imm s) -> true (* does lda $27, <s> *) - | Lop(Itailcall_ind) -> false - | Lop(Itailcall_imm s) -> - if s = f.fun_name then label_needs_gp tailrec_entry_point else true - | Lop(Iextcall(_, _)) -> true (* does lda $27, <s> *) - | Lop(Iload(_, Ibased(_, _))) -> true (* loads address from ($gp) *) - | Lop(Istore(_, Ibased(_, _))) -> true (* loads address from ($gp) *) - | Lop(Iintop(Idiv | Imod)) -> true (* divq and remq can be turned into *) - | Lop(Iintop_imm((Idiv | Imod), _)) -> true (* a function call *) - | Lop(Iintop_imm(_, n)) -> (* for large n, turned into ldq ($gp) *) - next || n < -0x80000000 || n > 0x7FFFFFFF - | Lop _ -> next - | Lreloadretaddr -> next - | Lreturn -> false - | Llabel lbl -> if next then set_label_needs_gp lbl; next - | Lbranch lbl -> label_needs_gp lbl - | Lcondbranch(tst, lbl) -> next || label_needs_gp lbl - | Lcondbranch3(lbl1, lbl2, lbl3) -> - opt_label_needs_gp next lbl1 || - opt_label_needs_gp next lbl2 || - opt_label_needs_gp next lbl3 - | Lswitch lblv -> true - | Lsetuptrap lbl -> label_needs_gp lbl - | Lpushtrap -> next - | Lpoptrap -> next - | Lraise -> false in - - let rec needs_gp i = - if i.desc = Lend - then false - else instr_needs_gp (needs_gp i.next) i.desc in - - while not !fixpoint_reached do - fixpoint_reached := true; - if needs_gp f.fun_body then set_label_needs_gp tailrec_entry_point - done; - - (* Insert Ireloadgp instructions after calls where needed *) - let rec insert_reload_gp i = - if i.desc = Lend then (i, false) else begin - let (new_next, needs_next) = insert_reload_gp i.next in - let new_instr = - match i.desc with - (* If the instruction destroys $gp and $gp is needed afterwards, - insert a ldgp after the instructions. *) - Lop(Icall_ind | Icall_imm _) when needs_next -> - {i with next = - instr_cons (Lop(Ispecific(Ireloadgp true))) [||] [||] new_next } - | Lop(Iextcall(_, false)) | Lsetuptrap _ when needs_next -> - {i with next = - instr_cons (Lop(Ispecific(Ireloadgp false))) [||] [||] new_next } - | _ -> - {i with next = new_next} in - (new_instr, instr_needs_gp needs_next i.desc) - end in - - let (new_body, uses_gp) = insert_reload_gp f.fun_body in - ({f with fun_body = new_body}, uses_gp) - -(* Second pass: code generation proper *) - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Output a label *) - -let emit_label lbl = - emit_string "$"; emit_int lbl - -let emit_Llabel fallthrough lbl = - if (not fallthrough) then begin - emit_string " .align 4\n" - end ; - emit_label 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_alpha.emit_reg" - -(* Layout of the stack frame *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + - (if !contains_calls then 8 else 0) in - Misc.align size 16 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n - | Local n -> - if cl = 0 - then !stack_offset + n * 8 - else !stack_offset + (num_stack_slots.(0) + 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 `{emit_int ofs}($sp)` - | _ -> fatal_error "Emit_alpha.emit_stack" - -(* Output an addressing mode *) - -let emit_addressing addr r n = - match addr with - Iindexed ofs -> - `{emit_int ofs}({emit_reg r.(n)})` - | Ibased(s, ofs) -> - `{emit_symbol s}`; - if ofs > 0 then ` + {emit_int ofs}`; - if ofs < 0 then ` - {emit_int(-ofs)}` - -(* Immediate operands *) - -let is_immediate n = digital_asm || (n >= 0 && n <= 255) - -(* Communicate live registers at call points to the assembler *) - -let int_reg_number = [| - 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; - 16; 17; 18; 19; 20; 21; 22 -|] - -let float_reg_number = [| - 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; - 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30 -|] - -let liveregs instr extra_msk = - (* $13, $14, $15 always live *) - let int_mask = ref(0x00070000 lor extra_msk) - and float_mask = ref 0 in - let add_register = function - {loc = Reg r; typ = (Int | Addr)} -> - int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) - | {loc = Reg r; typ = Float} -> - float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) - | _ -> () in - Reg.Set.iter add_register instr.live; - Array.iter add_register instr.arg; - emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask - -let live_24 = 1 lsl (31 - 24) -let live_25 = 1 lsl (31 - 25) -let live_26 = 1 lsl (31 - 26) -let live_27 = 1 lsl (31 - 27) - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - lbl - -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:` - -let emit_frame fd = - ` .quad {emit_label fd.fd_lbl}\n`; - ` .word {emit_int fd.fd_frame_size}\n`; - ` .word {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .word {emit_int n}\n`) - fd.fd_live_offset; - ` .align 3\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 *) - gc_instr: instruction } (* Record live registers *) - -let call_gc_sites = ref ([] : gc_call list) - -let emit_call_gc gc = - `{emit_label gc.gc_lbl}:`; - liveregs gc.gc_instr 0; - ` bsr $26, caml_call_gc\n`; - (* caml_call_gc preserves $gp *) - `{emit_label gc.gc_frame}: br {emit_label gc.gc_return_lbl}\n` - -(* Name of readonly data section *) - -let rdata_section = - match Config.system with - "digital" -> ".rdata" - | "linux" | "openbsd" | "netbsd" | "freebsd" | "gnu" -> ".section .rodata" - | _ -> assert false - -(* Names of various instructions *) - -let name_for_int_operation = function - Iadd -> "addq" - | Isub -> "subq" - | Imul -> "mulq" - | Idiv -> "divq" - | Imod -> "remq" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sll" - | Ilsr -> "srl" - | Iasr -> "sra" - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "fneg" - | Iabsf -> "fabs" - | Iaddf -> "addt" - | Isubf -> "subt" - | Imulf -> "mult" - | Idivf -> "divt" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -let name_for_specific_operation = function - Iadd4 -> "s4addq" - | Iadd8 -> "s8addq" - | Isub4 -> "s4subq" - | Isub8 -> "s8subq" - | _ -> Misc.fatal_error "Emit.name_for_specific_operation" - -let name_for_int_comparison = function - Isigned Ceq -> "cmpeq", true | Isigned Cne -> "cmpeq", false - | Isigned Cle -> "cmple", true | Isigned Cgt -> "cmple", false - | Isigned Clt -> "cmplt", true | Isigned Cge -> "cmplt", false - | Iunsigned Ceq -> "cmpeq", true | Iunsigned Cne -> "cmpeq", false - | Iunsigned Cle -> "cmpule", true | Iunsigned Cgt -> "cmpule", false - | Iunsigned Clt -> "cmpult", true | Iunsigned Cge -> "cmpult", false - -(* Used for comparisons against 0 *) -let name_for_int_cond_branch = function - Isigned Ceq -> "beq" | Isigned Cne -> "bne" - | Isigned Cle -> "ble" | Isigned Cgt -> "bgt" - | Isigned Clt -> "blt" | Isigned Cge -> "bge" - | Iunsigned Ceq -> "beq" | Iunsigned Cne -> "bne" - | Iunsigned Cle -> "beq" | Iunsigned Cgt -> "bne" - | Iunsigned Clt -> "#" | Iunsigned Cge -> "br" - (* Always false *) (* Always true *) - -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> ("cmpteq", false, neg) | Cne -> ("cmpteq", false, not neg) - | Cle -> ("cmptle", false, neg) | Cgt -> ("cmptlt", true, neg) - | Clt -> ("cmptlt", false, neg) | Cge -> ("cmptle", true, neg) - -(* 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 -(* List of floating-point and big integer literals - (fon non-Digital assemblers) *) -let float_constants = ref ([] : (label * string) list) -let bigint_constants = ref ([] : (label * nativeint) list) - -let emit_instr fallthrough i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src.loc, dst.loc) with - (Reg rs, Reg rd) -> - if src.typ = Float then - ` fmov {emit_reg src}, {emit_reg dst}\n` - else - ` mov {emit_reg src}, {emit_reg dst}\n` - | (Reg rs, Stack sd) -> - if src.typ = Float then - ` stt {emit_reg src}, {emit_stack dst}\n` - else - ` stq {emit_reg src}, {emit_stack dst}\n` - | (Stack ss, Reg rd) -> - if src.typ = Float then - ` ldt {emit_reg dst}, {emit_stack src}\n` - else - ` ldq {emit_reg dst}, {emit_stack src}\n` - | _ -> - fatal_error "Emit_alpha: Imove" - end - | Lop(Iconst_int n) -> - if n = 0n then - ` clr {emit_reg i.res.(0)}\n` - else if digital_asm || - (n >= Nativeint.of_int (-0x80000000) && - n <= Nativeint.of_int 0x7FFFFFFF) then - ` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n` - else begin - (* Work around a bug in gas/gld concerning big integer constants *) - let lbl = new_label() in - bigint_constants := (lbl, n) :: !bigint_constants; - ` lda $25, {emit_label lbl}\n`; - ` ldq {emit_reg i.res.(0)}, 0($25)\n` - end - | Lop(Iconst_float s) -> - if digital_asm then - ` ldit {emit_reg i.res.(0)}, {emit_string s}\n` - else if Int64.bits_of_float (float_of_string s) = 0L then - ` fmov $f31, {emit_reg i.res.(0)}\n` - else begin - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; - ` lda $25, {emit_label lbl}\n`; - ` ldt {emit_reg i.res.(0)}, 0($25)\n` - end - | Lop(Iconst_symbol s) -> - ` lda {emit_reg i.res.(0)}, {emit_symbol s}\n` - | Lop(Icall_ind) -> - liveregs i 0; - ` mov {emit_reg i.arg.(0)}, $27\n`; - ` jsr ({emit_reg i.arg.(0)})\n`; - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - liveregs i 0; - ` jsr {emit_symbol s}\n`; - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` ldq $26, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - ` mov {emit_reg i.arg.(0)}, $27\n`; - liveregs i (live_26 + live_27); - ` jmp ({emit_reg i.arg.(0)})\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - ` br {emit_label !tailrec_entry_point}\n` - end else begin - let n = frame_size() in - if !contains_calls then - ` ldq $26, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - ` lda $27, {emit_symbol s}\n`; - liveregs i (live_26 + live_27); - ` br {emit_symbol s}\n` - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` lda $25, {emit_symbol s}\n`; - liveregs i live_25; - ` bsr $26, caml_c_call\n`; - `{record_frame i.live}\n` - end else begin - ` jsr {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - ` lda $sp, {emit_int (-n)}($sp)\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - let load_instr = - match chunk with - | Byte_unsigned -> "ldbu" - | Byte_signed -> "ldb" - | Sixteen_unsigned -> "ldwu" - | Sixteen_signed -> "ldw" - | Thirtytwo_unsigned -> "ldl" - | Thirtytwo_signed -> "ldl" - | Word -> "ldq" - | Single -> "lds" - | Double -> "ldt" - | Double_u -> "ldt" in - ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; - if chunk = Thirtytwo_unsigned then - ` zapnot {emit_reg dest}, 15, {emit_reg dest}\n` - | Lop(Istore(chunk, addr)) -> - let store_instr = - match chunk with - | Byte_unsigned | Byte_signed -> "stb" - | Sixteen_unsigned | Sixteen_signed -> "stw" - | Thirtytwo_unsigned | Thirtytwo_signed -> "stl" - | Word -> "stq" - | Single -> "sts" - | Double -> "stt" - | Double_u -> "stt" in - ` {emit_string store_instr} {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame; - gc_instr = i } :: !call_gc_sites; - `{emit_label lbl_redo}: lda $13, -{emit_int n}($13)\n`; - ` cmpult $13, $14, $25\n`; - ` bne $25, {emit_label lbl_call_gc}\n`; - ` addq $13, 8, {emit_reg i.res.(0)}\n` - end else begin - begin match n with - 16 -> liveregs i 0; - ` bsr $26, caml_alloc1\n` - | 24 -> liveregs i 0; - ` bsr $26, caml_alloc2\n` - | 32 -> liveregs i 0; - ` bsr $26, caml_alloc3\n` - | _ -> ` ldiq $25, {emit_int n}\n`; - liveregs i live_25; - ` bsr $26, caml_allocN\n` - end; - (* $gp preserved by caml_alloc* *) - `{record_frame i.live} addq $13, 8, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop(Icomp cmp)) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; - if not test then - ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` - | Lop(Iintop(Icheckbound)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` cmpule {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; - ` bne $25, {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(Idiv, n)) -> - if n = 1 lsl (Misc.log2 n) then begin - let l = Misc.log2 n in - if is_immediate n then - ` addq {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` - else begin - ` ldiq $25, {emit_int(n-1)}\n`; - ` addq {emit_reg i.arg.(0)}, $25, $25\n` - end; - ` cmovge {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`; - ` sra $25, {emit_int l}, {emit_reg i.res.(0)}\n` - end else begin - (* divq with immediate arg is incorrectly assembled in Tru64 5.1, - so emulate it ourselves *) - ` ldiq $25, {emit_int n}\n`; - ` divq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Imod, n)) -> - if n = 1 lsl (Misc.log2 n) then begin - if is_immediate n then - ` and {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` - else begin - ` ldiq $25, {emit_int (n-1)}\n`; - ` and {emit_reg i.arg.(0)}, $25, $25\n` - end; - ` subq $25, {emit_int n}, $24\n`; - ` cmovge {emit_reg i.arg.(0)}, $25, $24\n`; - ` cmoveq $25, $25, $24\n`; - ` mov $24, {emit_reg i.res.(0)}\n` - end else begin - (* remq with immediate arg is incorrectly assembled in Tru64 5.1, - so emulate it ourselves *) - ` ldiq $25, {emit_int n}\n`; - ` remq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Ilsl, 1)) -> - (* Turn x << 1 into x + x, slightly faster according to the docs *) - ` addq {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; - if not test then - ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` - - | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` cmpule {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; - ` bne $25, {emit_label !range_check_trap}\n` - | Lop(Iintop_imm(op, n)) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf | Iabsf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | 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(Ifloatofint) -> - ` .set noat\n`; - ` lda $sp, -8($sp)\n`; - ` stq {emit_reg i.arg.(0)}, 0($sp)\n`; - ` ldt $f28, 0($sp)\n`; - ` cvtqt $f28, {emit_reg i.res.(0)}\n`; - ` lda $sp, 8($sp)\n`; - ` .set at\n` - | Lop(Iintoffloat) -> - ` .set noat\n`; - ` lda $sp, -8($sp)\n`; - ` cvttqc {emit_reg i.arg.(0)}, $f28\n`; - ` stt $f28, 0($sp)\n`; - ` ldq {emit_reg i.res.(0)}, 0($sp)\n`; - ` lda $sp, 8($sp)\n`; - ` .set at\n` - | Lop(Ispecific(Ireloadgp marked_r26)) -> - ` ldgp $gp, 0($26)\n`; - if marked_r26 then - ` bic $gp, 1, $gp\n` - | Lop(Ispecific Itrunc32) -> - ` addl {emit_reg i.arg.(0)}, 0, {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 - ` ldq $26, {emit_int(n - 8)}($sp)\n` - | Lreturn -> - let n = frame_size() in - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - liveregs i live_26; - ` ret ($26)\n` - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` br {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Ifalsetest -> - ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Iinttest cmp -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; - if test then - ` bne $25, {emit_label lbl}\n` - else - ` beq $25, {emit_label lbl}\n` - | Iinttest_imm(cmp, 0) -> - let branch = name_for_int_cond_branch cmp in - ` {emit_string branch} {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; - if test then - ` bne $25, {emit_label lbl}\n` - else - ` beq $25, {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - ` .set noat\n`; - let (comp, swap, test) = name_for_float_comparison cmp neg in - ` {emit_string comp} `; - if swap - then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f28\n` - else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f28\n`; - if test - then ` fbeq $f28, {emit_label lbl}\n` - else ` fbne $f28, {emit_label lbl}\n`; - ` .set at\n` - | Ioddtest -> - ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Ieventest -> - ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - begin match lbl0 with - None -> () - | Some lbl -> ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> - if lbl0 <> None then - ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` - else if lbl1 <> None then - ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` - else begin - ` subq {emit_reg i.arg.(0)}, 2, $25\n`; - ` beq $25, {emit_label lbl}\n` - end - end - | Lswitch jumptbl -> - let lbl_jumptbl = new_label() in - ` lda $25, {emit_label lbl_jumptbl}\n`; - ` s4addq {emit_reg i.arg.(0)}, $25, $25\n`; - ` ldl $25, 0($25)\n`; - ` addq $gp, $25, $25\n`; - ` jmp ($25), {emit_label jumptbl.(0)}\n`; - ` {emit_string rdata_section}\n`; - `{emit_label lbl_jumptbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .gprel32 {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` br $25, {emit_label lbl}\n` - | Lpushtrap -> - stack_offset := !stack_offset + 16; - ` lda $sp, -16($sp)\n`; - ` stq $15, 0($sp)\n`; - ` stq $25, 8($sp)\n`; - ` mov $sp, $15\n` - | Lpoptrap -> - ` ldq $15, 0($sp)\n`; - ` lda $sp, 16($sp)\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - ` ldq $26, 8($15)\n`; - ` mov $15, $sp\n`; - ` ldq $15, 0($sp)\n`; - ` lda $sp, 16($sp)\n`; - liveregs i live_26; - ` jmp $25, ($26)\n` (* Keep retaddr in $25 for debugging *) - -let rec emit_all fallthrough i = match i.desc with -| Lend -> () -| _ -> - emit_instr fallthrough i; - emit_all (has_fallthrough i.desc) i.next - -(* Emission of a function declaration *) - -let emit_fundecl (fundecl, needs_gp) = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - stack_offset := 0; - call_gc_sites := []; - range_check_trap := 0; - float_constants := []; - bigint_constants := []; - ` .text\n`; - ` .align 4\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - ` .ent {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - if needs_gp then begin - ` .set noreorder\n`; - ` ldgp $gp, 0($27)\n`; - ` .set reorder\n` - end; - let n = frame_size() in - if n > 0 then - ` lda $sp, -{emit_int n}($sp)\n`; - if !contains_calls then begin - ` stq $26, {emit_int(n - 8)}($sp)\n`; - ` .mask 0x04000000, -8\n`; - ` .fmask 0x0, 0\n` - end; - ` .frame $sp, {emit_int n}, $26\n`; - ` .prologue {emit_int(if needs_gp then 1 else 0)}\n`; - tailrec_entry_point := new_label(); - `{emit_label !tailrec_entry_point}:\n`; - emit_all true fundecl.fun_body; - List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then begin - `{emit_label !range_check_trap}:\n`; - ` br $26, caml_ml_array_bound_error\n` - (* Keep retaddr in $26 for debugging *) - end; - ` .end {emit_symbol fundecl.fun_name}\n`; - if !bigint_constants <> [] then begin - ` {emit_string rdata_section}\n`; - ` .align 3\n`; - List.iter - (fun (lbl, n) -> `{emit_label lbl}: .quad 0x{emit_string(Nativeint.format "%x" n)}\n`) - !bigint_constants - end; - if !float_constants <> [] then begin - ` {emit_string rdata_section}\n`; - ` .align 3\n`; - List.iter - (fun (lbl, s) -> `{emit_label lbl}: .t_floating {emit_string s}\n`) - !float_constants - end - -let fundecl f = - emit_fundecl (insert_load_gp f) - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .word {emit_int n}\n` - | Cint32 n -> - let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in - ` .long {emit_nativeint n'}\n` - | Cint n -> - if digital_asm then - ` .quad {emit_nativeint n}\n` - else - (* Work around a bug in gas regarding the parsing of - long decimal constants *) - ` .quad 0x{emit_string(Nativeint.format "%x" n)}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_directive ".quad" f - | Csymbol_address s -> - ` .quad {emit_symbol s}\n` - | Clabel_address lbl -> - ` .quad {emit_label (100000 + 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() = - (* There are really two groups of registers: - $sp and $15 always point to stack locations - $0 - $14, $16-$23 never point to stack locations. *) - ` .noalias $0,$sp; .noalias $0,$15; .noalias $1,$sp; .noalias $1,$15\n`; - ` .noalias $2,$sp; .noalias $2,$15; .noalias $3,$sp; .noalias $3,$15\n`; - ` .noalias $4,$sp; .noalias $4,$15; .noalias $5,$sp; .noalias $5,$15\n`; - ` .noalias $6,$sp; .noalias $6,$15; .noalias $7,$sp; .noalias $7,$15\n`; - ` .noalias $8,$sp; .noalias $8,$15; .noalias $9,$sp; .noalias $9,$15\n`; - ` .noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`; - ` .noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`; - ` .noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`; - ` .noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`; - ` .noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`; - ` .noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`; - ` .noalias $23,$sp; .noalias $23,$15\n\n`; - (* The following .file directive is intended to prevent the generation - of line numbers for the debugger, 'cos they make .o files larger - and slow down linking. *) - ` .file 1 \"{emit_string !Location.input_name}\"\n\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n` - -let end_assembly () = - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .data\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .quad 0\n`; - let lbl_frame = Compilenv.make_symbol (Some "frametable") in - ` {emit_string rdata_section}\n`; - ` .globl {emit_symbol lbl_frame}\n`; - `{emit_symbol lbl_frame}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml deleted file mode 100644 index 7c126ca15..000000000 --- a/asmcomp/alpha/proc.ml +++ /dev/null @@ -1,217 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Description of the Alpha processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = true - -(* Registers available for register allocation *) - -(* Register map: - $0 - $7 0 - 7 function results - $8 - $12 8 - 12 general purpose ($9 - $15 are preserved by C) - $13 allocation pointer - $14 allocation limit - $15 trap pointer - $16 - $22 13 - 19 function arguments - $23 - $25 temporaries (for the code gen and for the asm) - $26 - $30 stack ptr, global ptr, etc - $31 always zero - - $f0 - $f7 100 - 107 function results - $f8 - $f15 108 - 115 general purpose ($f2 - $f9 preserved by C) - $f16 - $f23 116 - 123 function arguments - $f24 - $f30 124 - 129 general purpose - $f28 temporary - $f31 always zero *) - -let int_reg_name = [| - (* 0-7 *) "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; - (* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12"; - (* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22" -|] - -let float_reg_name = [| - (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; - (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15"; - (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23"; - (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f29"; "$f30" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 20; 30 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 20 Reg.dummy in - for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 30 Reg.dummy in - for i = 0 to 29 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 13 18 116 123 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 13 18 116 123 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 7 100 107 not_supported res in loc - -(* On the Alpha, C functions have calling conventions similar to those - for Caml functions, except that integer and floating-point registers - for arguments are allocated "in sequence". E.g. a function - taking a float f1 and two ints i2 and i3 will put f1 in the - first float reg, i2 in the second int reg and i3 in the third int reg. *) - -let ext_calling_conventions first_int last_int first_float last_float - make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; incr int; incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; incr int; incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let loc_external_arguments arg = - ext_calling_conventions 13 18 116 121 outgoing arg -let loc_external_results res = - let (loc, ofs) = ext_calling_conventions 0 0 100 100 not_supported res in loc -let extcall_use_push = false - -let loc_exn_bucket = phys_reg 0 (* $0 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* $9 - $12, $f2 - $f9 preserved *) - Array.of_list(List.map phys_reg - [0;1;2;3;4;5;6;7;8;13;14;15;16;17;18;19; - 100;101;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124; - 125;126;127;128;129]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 4 - | _ -> 19 -let max_register_pressure = function - Iextcall(_, _) -> [| 4; 8 |] - | _ -> [| 19; 29 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - let as_cmd = - if digital_asm && !Clflags.gprofile - then Config.asm ^ " -pg" - else Config.asm in - Ccomp.command (as_cmd ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/alpha/reload.ml b/asmcomp/alpha/reload.ml deleted file mode 100644 index 095767ebb..000000000 --- a/asmcomp/alpha/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Reloading for the Alpha *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/alpha/scheduling.ml b/asmcomp/alpha/scheduling.ml deleted file mode 100644 index e1fd603db..000000000 --- a/asmcomp/alpha/scheduling.ml +++ /dev/null @@ -1,70 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -open Arch -open Mach - -(* The Digital Unix assembler does scheduling better than us. - However, the Linux-Alpha assembler does not do scheduling, so we do - a feeble attempt here. *) - -class scheduler = object (self) - -inherit Schedgen.scheduler_generic as super - -(* Latencies (in cycles). Based on the 21064, with some poetic license. *) - -method oper_latency = function - Ireload -> 3 - | Iload(_, _) -> 3 - | Iconst_symbol _ -> 3 (* turned into a load *) - | Iconst_float _ -> 3 (* ends up in a load *) - | Iintop(Imul) -> 23 - | Iintop_imm(Imul, _) -> 23 - | Iaddf -> 6 - | Isubf -> 6 - | Imulf -> 6 - | Idivf -> 63 - | _ -> 2 - (* Most arithmetic instructions can be executed back-to-back in 1 cycle. - However, some combinations (arith; load or arith; store) require 2 - cycles. Also, by claiming 2 cycles instead of 1, we might favor - dual issue. *) - -(* Issue cycles. Rough approximations. *) - -method oper_issue_cycles = function - Iconst_float _ -> 4 (* load from $gp, then load *) - | Ialloc _ -> 4 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 3 - | Iintop_imm(Imod, _) -> 5 - | Iintop_imm(Icheckbound, _) -> 2 - | Ifloatofint -> 10 - | Iintoffloat -> 10 - | _ -> 1 - -(* Say that reloadgp is not part of a basic block (prevents moving it - past an operation that uses $gp) *) - -method oper_in_basic_block = function - Ispecific(Ireloadgp _) -> false - | op -> super#oper_in_basic_block op - -end - -let fundecl = - if digital_asm - then (fun f -> f) - else (new scheduler)#schedule_fundecl diff --git a/asmcomp/alpha/selection.ml b/asmcomp/alpha/selection.ml deleted file mode 100644 index c86e931be..000000000 --- a/asmcomp/alpha/selection.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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$ *) - -(* Instruction selection for the Alpha processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -method is_immediate n = digital_asm || (n >= 0 && n <= 255) - -method select_addressing = function - (* Force an explicit lda for non-scheduling assemblers, - this allows our scheduler to do a better job. *) - Cconst_symbol s when digital_asm -> - (Ibased(s, 0), Ctuple []) - | Cop((Cadda | Caddi), [Cconst_symbol s; Cconst_int n]) when digital_asm -> - (Ibased(s, n), Ctuple []) - | Cop((Cadda | Caddi), [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop((Cadda | Caddi), [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -method! select_operation op args = - match (op, args) with - (* Recognize shift-add operations *) - ((Caddi|Cadda), - [arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> - (Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2]) - | (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> - (Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2]) - (* Recognize truncation/normalization of 64-bit integers to 32 bits *) - | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> - (Ispecific Itrunc32, [arg]) - (* Work around various limitations of the GNU assembler *) - | ((Caddi|Cadda), [arg1; Cconst_int n]) - when not (self#is_immediate n) && self#is_immediate (-n) -> - (Iintop_imm(Isub, -n), [arg1]) - | (Cdivi, [arg1; Cconst_int n]) - when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> - (Iintop Idiv, args) - | (Cmodi, [arg1; Cconst_int n]) - when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> - (Iintop Imod, args) - | _ -> - super#select_operation op args - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml deleted file mode 100644 index 195c28e6f..000000000 --- a/asmcomp/hppa/arch.ml +++ /dev/null @@ -1,73 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Specific operations for the HP PA-RISC processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Specific operations *) - -type specific_operation = - Ishift1add - | Ishift2add - | Ishift3add - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Sizes, endianness *) - -let big_endian = true - -let size_addr = 4 -let size_int = 4 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "\"%s\"%s" s idx - | Iindexed n -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "%a%s" printreg arg.(0) idx - -let print_specific_operation printreg op ppf arg = - match op with - | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) - | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) - | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp deleted file mode 100644 index d35544109..000000000 --- a/asmcomp/hppa/emit.mlp +++ /dev/null @@ -1,1042 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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() diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml deleted file mode 100644 index 7ee20040f..000000000 --- a/asmcomp/hppa/proc.ml +++ /dev/null @@ -1,224 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Description of the HP PA-RISC processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Registers available for register allocation *) - -(* Register map: - %r0 always zero - %r1 temporary, target of ADDIL - %r2 return address - %r3 allocation pointer - %r4 allocation limit - %r5 trap pointer - %r6 - %r26 general purpose - %r27 global pointer - %r28 - %r29 general purpose, C function results - %r30 stack pointer - %r31 temporary, used by BLE - - %fr0 - %fr3 float status info - %fr4 - %fr30 general purpose - %fr31 temporary *) - -let int_reg_name = [| - (* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10"; - (* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16"; - (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22"; - (* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26"; - (* 21-22 *) "%r28"; "%r29" -|] - -let float_reg_name = [| - (* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9"; - (* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15"; - (* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21"; - (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27"; - (* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 23; 27 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 23 Reg.dummy in - for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 28 Reg.dummy in - for i = 0 to 27 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg (Array.sub hard_float_reg 0 27) - (* No need to include the left/right parts of float registers *) - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Instruction selection *) - -let word_addressed = false - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int >= last_int then begin - loc.(i) <- phys_reg !int; - decr int - end else begin - ofs := !ofs + size_int; - loc.(i) <- stack_slot (make_stack !ofs) ty - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - ofs := Misc.align (!ofs + size_float) 8; - loc.(i) <- stack_slot (make_stack !ofs) Float - end - done; - (loc, Misc.align !ofs 8) (* Keep stack 8-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -(* Arguments and results: %r26-%r19, %fr4-%fr11. *) - -let loc_arguments arg = - calling_conventions 20 13 100 107 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 20 13 100 107 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc - -(* Calling C functions: - when all arguments are integers, use %r26 - %r23, - then -52(%r30), -56(%r30), etc. - When some arguments are floats, we handle a couple of cases by hand - and fail otherwise. *) - -let loc_external_arguments arg = - match List.map register_class (Array.to_list arg) with - [1] -> ([| phys_reg 101 |], 56) (* %fr5 *) - | [1; 1] -> ([| phys_reg 101; phys_reg 103 |], 56) (* %fr5, %fr7 *) - | [1; 0] -> ([| phys_reg 101; phys_reg 18 |], 56) (* %fr5, %r24 *) - | [0; 1] -> ([| phys_reg 20; phys_reg 103 |], 56) (* %r26, %fr7 *) - | _ -> - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref 20 in - let ofs = ref 48 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int >= 17 then begin - loc.(i) <- phys_reg (!int); - decr int - end else begin - ofs := !ofs + 4; - loc.(i) <- stack_slot (Outgoing !ofs) ty - end - | Float -> - fatal_error "Proc.external_calling_conventions: cannot call" - done; - (loc, Misc.align !ofs 8) - -let loc_external_results res = - let (loc, ofs) = calling_conventions 21 21 100 100 not_supported res in loc - -let loc_exn_bucket = phys_reg 20 (* %r26 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* %r3 - %r18, %fr12 - %fr21 preserved *) - Array.of_list(List.map phys_reg - [13;14;15;16;17;18;19;20;21;22; - 100;101;102;103;104;105;106;107;118;119;120;121;122;123;124;125;126]) - -let destroyed_by_millicode = (* %r25, %r26, %r28, %r29 -- more? *) - [| phys_reg 19; phys_reg 20; phys_reg 21; phys_reg 22 |] - -let destroyed_by_alloc = [| phys_reg 22 |] (* %r29 *) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> destroyed_by_millicode - | Iop(Ialloc _) -> destroyed_by_alloc - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 16 - | Iintop(Idiv | Imod) -> 19 - | _ -> 23 - -let max_register_pressure = function - Iextcall(_, _) -> [| 16; 19 |] - | Iintop(Idiv | Imod) -> [| 19; 27 |] - | _ -> [| 23; 27 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml deleted file mode 100644 index b6fe65980..000000000 --- a/asmcomp/hppa/reload.ml +++ /dev/null @@ -1,38 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Reloading for the HPPA *) - - -open Cmm -open Arch -open Reg -open Mach -open Proc - -class reload = object (self) - -inherit Reloadgen.reload_generic as super - -method reload_operation op arg res = - match op with - Iintop(Idiv | Imod) - | Iintop_imm((Idiv | Imod), _) -> (arg, res) - | _ -> super#reload_operation op arg res -end - - - -let fundecl f = - (new reload)#fundecl f diff --git a/asmcomp/hppa/scheduling.ml b/asmcomp/hppa/scheduling.ml deleted file mode 100644 index b669aec21..000000000 --- a/asmcomp/hppa/scheduling.ml +++ /dev/null @@ -1,59 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Instruction scheduling for the HPPA *) - -open Arch -open Mach - -class scheduler = object (self) - -inherit Schedgen.scheduler_generic - -(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *) - -method oper_latency = function - Ireload -> 2 - | Iload(_, _) -> 2 - | Iconst_float _ -> 2 (* turned into a load *) - | Iintop Imul -> 2 (* ends up with a load *) - | Iaddf | Isubf | Imulf -> 3 - | Idivf -> 12 - | _ -> 1 - -(* Issue cycles. Rough approximations. *) - -method oper_issue_cycles = function - Iconst_float _ -> 3 - | Iconst_symbol _ -> 2 - | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 - | Ialloc _ -> 5 - | Iintop Imul -> 10 - | Iintop Ilsl -> 3 - | Iintop Ilsr -> 2 - | Iintop Iasr -> 3 - | Iintop(Icomp _) -> 2 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 5 - | Iintop_imm(Icomp _, _) -> 2 - | Iintop_imm(Icheckbound, _) -> 2 - | Ifloatofint -> 4 - | Iintoffloat -> 4 - | _ -> 1 - -end - -let fundecl f = (new scheduler)#schedule_fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml deleted file mode 100644 index 72792e2b0..000000000 --- a/asmcomp/hppa/selection.ml +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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$ *) - -(* Instruction selection for the HPPA processor *) - -open Misc -open Cmm -open Reg -open Arch -open Proc -open Mach - -let shiftadd = function - 2 -> Ishift1add - | 4 -> Ishift2add - | 8 -> Ishift3add - | _ -> fatal_error "Proc_hppa.shiftadd" - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -method is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) - -method select_addressing = function - Cconst_symbol s -> - (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> - (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -method! select_operation op args = - match (op, args) with - (* Recognize shift-add operations. *) - ((Caddi|Cadda), - [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) -> - (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) -> - (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - (* Prevent the recognition of some immediate arithmetic operations *) - (* Cmuli : -> Ilsl if power of 2 - Cdivi, Cmodi : only if power of 2 - Cand, Cor, Cxor : never *) - | (Cmuli, ([arg1; Cconst_int n] as args)) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else (Iintop Imul, args) - | (Cmuli, ([Cconst_int n; arg1] as args)) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else (Iintop Imul, args) - | (Cmuli, args) -> (Iintop Imul, args) - | (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | (Cdivi, args) -> (Iintop Idiv, args) - | (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | (Cmodi, args) -> (Iintop Imod, args) - | (Cand, args) -> (Iintop Iand, args) - | (Cor, args) -> (Iintop Ior, args) - | (Cxor, args) -> (Iintop Ixor, args) - | _ -> - super#select_operation op args - -(* Deal with register constraints *) - -method! insert_op_debug op dbg rs rd = - match op with - Iintop(Idiv | Imod) -> (* handled via calls to millicode *) - let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) - and rd' = [|phys_reg 22|] (* %r29 *) in - self#insert_moves rs rs'; - self#insert_debug (Iop op) dbg rs' rd'; - self#insert_moves rd' rd; - rd - | _ -> - super#insert_op_debug op dbg rs rd - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/ia64/arch.ml b/asmcomp/ia64/arch.ml deleted file mode 100644 index 006660d4a..000000000 --- a/asmcomp/ia64/arch.ml +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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$ *) - -(* Specific operations for the IA64 processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes -- only one! (register with no displacement) *) - -type addressing_mode = Iindexed - -(* Specific operations *) - -type specific_operation = - Iadd1 (* x + y + 1 or x + x + 1 *) - | Isub1 (* x - y - 1 *) - | Ishladd of int (* x << N + y *) - | Isignextend of int (* truncate 64-bit int to 8N-bit int *) - | Imultaddf (* x *. y +. z *) - | Imultsubf (* x *. y -. z *) - | Isubmultf (* z -. x *. y *) - | Istoreincr of int (* store y at x; x <- x + N *) - | Iinitbarrier (* end of object initialization *) - -(* Sizes, endianness *) - -let big_endian = false - -let size_addr = 8 -let size_int = 8 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed - -let offset_addressing addr delta = assert false - -let num_args_addressing = function Iindexed -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - printreg ppf arg.(0) - -let print_specific_operation printreg op ppf arg = - match op with - | Iadd1 -> - if Array.length arg >= 2 then - fprintf ppf "%a + %a + 1 " printreg arg.(0) printreg arg.(1) - else - fprintf ppf "%a << 1 + 1 " printreg arg.(0) - | Isub1 -> - fprintf ppf "%a - %a - 1 " printreg arg.(0) printreg arg.(1) - | Ishladd n -> - fprintf ppf "%a << %d + %a" printreg arg.(0) n printreg arg.(1) - | Isignextend n -> - fprintf ppf "truncate%d %a" (n * 8) printreg arg.(0) - | Imultaddf -> - fprintf ppf "%a * %a + %a" - printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Imultsubf -> - fprintf ppf "%a * %a - %a" - printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Isubmultf -> - fprintf ppf "%a - %a * %a" - printreg arg.(2) printreg arg.(0) printreg arg.(1) - | Istoreincr n -> - fprintf ppf "[%a] := %a; %a += %d" - printreg arg.(0) printreg arg.(1) printreg arg.(0) n - | Iinitbarrier -> - fprintf ppf "initbarrier" diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp deleted file mode 100644 index b722af015..000000000 --- a/asmcomp/ia64/emit.mlp +++ /dev/null @@ -1,1327 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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 IA64 assembly code *) - -open Location -open Printf -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(************** Part 1: assembly-level scheduler *******************) - -(* Representation of resources accessed or produced by instructions *) - -type resource = string - (* A resource is either: - - a register name - - "stkN" for a stack location - - "heap" for the Caml heap - - "chkN" for the result of a checkbound instruction *) - -let is_memory_resource rsrc = - String.length rsrc >= 4 && - begin match String.sub rsrc 0 3 with - "stk" -> true - | "hea" -> true - | "chk" -> true - | _ -> false - end - -let is_mutable_resource rsrc = - rsrc <> "r0" && rsrc <> "p0" - -(* Description of instructions *) - -type instruction_kind = - KA (* A type instruction (int or mem unit) *) - | KB (* B type instruction (branch unit) *) - | KI (* I type instruction (int unit *) - | KF (* F type instruction (FP unit) *) - | KM (* M type instruction (mem unit) *) - | KB_exc (* B type instruction, exceptional condition, - can be moved around *) - -type instruction_format = - F_i (* op imm *) - | F_i_pred (* (pred) op imm *) - | F_ir_rr (* op p1,p2 = imm, r *) - | F_ir_r (* op r = imm, r *) - | F_ir_r_pred (* (pred) op r = imm, r *) - | F_ld (* op r = [r] *) - | F_ld_post (* op r = [r], imm *) - | F_r (* op r *) - | F_i_r (* op r = imm *) - | F_i_r_pred (* (pred) op r = imm *) - | F_ri_rr (* op p1,p2 = imm, r *) - | F_ri_r (* op r = imm, r *) - | F_r_r (* op r = r *) - | F_r_r_pred (* (pred) op r = r *) - | F_rr_rr (* op p1,p2 = r1, r2 *) - | F_r_rir (* op r = r1, imm, r2 *) - | F_rr_r (* op r = r1, r2 *) - | F_rr_r_pred (* (pred) op r = r1, r2 *) - | F_rri_r (* op r = r1, r2, imm *) - | F_rrr_r (* op r = r1, r2, r3 *) - | F_rrr_r_pred (* (pred) op r = r1, r2, r3 *) - | F_st (* op [r] = r *) - | F_st_post (* op [r] = r, imm *) - -type instruction_descr = - { opcode: string; (* actual opcode *) - latency: int; (* latency in cycles *) - kind: instruction_kind; (* kind of instruction *) - format: instruction_format } (* how to generate asm for it *) - -let instruction_table = create_hashtable 73 [ - "add", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r}; - "add1", {opcode = "add"; latency = 1; kind = KA; format = F_rri_r}; - "addcond", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r_pred}; - "addi", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r}; - "addicond", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r_pred}; - "and", {opcode = "and"; latency = 1; kind = KA; format = F_rr_r}; - "andi", {opcode = "and"; latency = 1; kind = KA; format = F_ir_r}; - "br", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_i}; - "brret", {opcode = "br.ret.sptk"; latency = 1; kind = KB; format = F_r}; - "brcall", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_i_r}; - "brcallcond", {opcode = "br.call.spnt.many"; latency = 1; kind = KB; format = F_i_r_pred}; - "brcallcondexc", {opcode = "br.call.spnt.many"; latency = 1; kind = KB_exc; format = F_i_r_pred}; - "brcallind", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_r_r}; - "brcond", {opcode = "br.dpnt.many"; latency = 1; kind = KB; format = F_i_pred}; - "brind", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_r}; - "cmp.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_rr_rr}; - "cmpi.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpp.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ne.and", {opcode = "cmp.ne.and"; latency = 1; kind = KA; format = F_rr_rr}; - "cmppi.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_ir_rr}; - "extr.u", {opcode = "extr.u"; latency = 1; kind = KI; format = F_ri_r}; - "fabs", {opcode = "fabs"; latency = 1; kind = KF; format = F_r_r}; - "fadd.d", {opcode = "fadd.d"; latency = 5; kind = KF; format = F_rr_r}; - "fcmp.eq", {opcode = "fcmp.eq"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.ge", {opcode = "fcmp.ge"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.gt", {opcode = "fcmp.gt"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.le", {opcode = "fcmp.le"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.lt", {opcode = "fcmp.lt"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.neq", {opcode = "fcmp.neq"; latency = 1; kind = KF; format = F_rr_rr}; - "fcvt.fx.trunc", {opcode = "fcvt.fx.trunc"; latency = 7; kind = KF; format = F_r_r}; - "fcvt.xf", {opcode = "fcvt.xf"; latency = 5; kind = KF; format = F_r_r}; - "fma.d", {opcode = "fma.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fmacond", {opcode = "fma.d.s0"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmas1cond", {opcode = "fma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmads1cond", {opcode = "fma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmpy.d", {opcode = "fmpy.d"; latency = 5; kind = KF; format = F_rr_r}; - "fms.d", {opcode = "fms.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fneg", {opcode = "fneg"; latency = 1; kind = KF; format = F_r_r}; - "fnma.d", {opcode = "fnma.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fnmas1cond", {opcode = "fnma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fnmads1cond", {opcode = "fnma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fnorm.d", {opcode = "fnorm.d"; latency = 5; kind = KF; format = F_r_r}; - "frcpa", {opcode = "frcpa.s0"; latency = 5; kind = KF; format = F_rr_rr}; - "fsub.d", {opcode = "fsub.d"; latency = 5; kind = KF; format = F_rr_r}; - "getf.sig", {opcode = "getf.sig"; latency = 2; kind = KM; format = F_r_r}; - "ld1", {opcode = "ld1"; latency = 2; kind = KM; format = F_ld}; - "ld2", {opcode = "ld2"; latency = 2; kind = KM; format = F_ld}; - "ld4", {opcode = "ld4"; latency = 2; kind = KM; format = F_ld}; - "ld8", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld}; - "ld8+", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld_post}; - "ldfd", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld}; - "ldfd+", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld_post}; - "ldfs", {opcode = "ldfs"; latency = 9; kind = KM; format = F_ld}; - "mov", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r}; - "movcond", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r_pred}; - "movtb", {opcode = "mov"; latency = 9; kind = KI; format = F_r_r}; - "movfb", {opcode = "mov"; latency = 2; kind = KI; format = F_r_r}; - "movi", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r}; - "movicond", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r_pred}; - "movil", {opcode = "movl"; latency = 1; kind = KI; format = F_i_r}; - "movpr", {opcode = "mov"; latency = 1; kind = KI; format = F_ri_r}; - "or", {opcode = "or"; latency = 1; kind = KA; format = F_rr_r}; - "ori", {opcode = "or"; latency = 1; kind = KA; format = F_ir_r}; - "setf.d", {opcode = "setf.d"; latency = 8; kind = KM; format = F_r_r}; - "setf.sig", {opcode = "setf.sig"; latency = 8; kind = KM; format = F_r_r}; - "shl", {opcode = "shl"; latency = 2; kind = KI; format = F_rr_r}; - "shladd", {opcode = "shladd"; latency = 1; kind = KA; format = F_r_rir}; - "shli", {opcode = "shl"; latency = 1; kind = KI; format = F_ri_r}; - "shr", {opcode = "shr"; latency = 2; kind = KI; format = F_rr_r}; - "shri", {opcode = "shr"; latency = 1; kind = KI; format = F_ri_r}; - "shru", {opcode = "shr.u"; latency = 2; kind = KI; format = F_rr_r}; - "shrui", {opcode = "shr.u"; latency = 1; kind = KI; format = F_ri_r}; - "st1", {opcode = "st1"; latency = 0; kind = KM; format = F_st}; - "st2", {opcode = "st2"; latency = 0; kind = KM; format = F_st}; - "st4", {opcode = "st4"; latency = 0; kind = KM; format = F_st}; - "st8", {opcode = "st8"; latency = 0; kind = KM; format = F_st}; - "st8+", {opcode = "st8"; latency = 1; kind = KM; format = F_st_post}; - "stfd", {opcode = "stfd"; latency = 0; kind = KM; format = F_st}; - "stfd+", {opcode = "stfd"; latency = 1; kind = KM; format = F_st_post}; - "stfs", {opcode = "stfs"; latency = 0; kind = KM; format = F_st}; - "sub", {opcode = "sub"; latency = 1; kind = KA; format = F_rr_r}; - "sub1", {opcode = "sub"; latency = 1; kind = KA; format = F_rri_r}; - "subi", {opcode = "sub"; latency = 1; kind = KA; format = F_ir_r}; - "sxt1", {opcode = "sxt1"; latency = 1; kind = KI; format = F_r_r}; - "sxt2", {opcode = "sxt2"; latency = 1; kind = KI; format = F_r_r}; - "sxt4", {opcode = "sxt4"; latency = 1; kind = KI; format = F_r_r}; - "tbit.nz", {opcode = "tbit.nz"; latency = 0; kind = KI; format = F_ri_rr}; - "tbit.z", {opcode = "tbit.z"; latency = 0; kind = KI; format = F_ri_rr}; - "xmpy.l", {opcode = "xmpy.l"; latency = 7; kind = KF; format = F_rr_r}; - "xor", {opcode = "xor"; latency = 1; kind = KA; format = F_rr_r}; - "xori", {opcode = "xor"; latency = 1; kind = KA; format = F_ir_r}; - "#initbarrier", {opcode = "# init barrier"; latency = 0; kind = KI; format = F_i}; -] - -(* Nodes of the code DAG. Each node represents one instruction to be - emitted. *) - -type code_dag_node = - { instr: instruction_descr; (* the instruction *) - imm: string; (* its immediate argument, if any *) - iarg: resource array; (* arguments *) - ires: resource array; (* results *) - delay: int; (* how many cycles before result is available *) - mutable sons: (code_dag_node * int) list; - (* nodes that depend on this node *) - mutable date: int; (* start date *) - mutable length: int; (* length of longest path to result *) - mutable ancestors: int; (* number of ancestors *) - mutable emitted_ancestors: int } (* number of emitted ancestors *) - -(* The code dag itself is represented by two tables from resources to nodes: - - "results" maps resources to the instructions that produced them; - - "uses" maps resources to the instructions that use them. *) - -let code_results = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) -let code_uses = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) - -let clear_code_dag () = - Hashtbl.clear code_results; - Hashtbl.clear code_uses - -(* The ready queue: a list of nodes that can be computed immediately - (all arguments are available), kept sorted by decreasing length to results. - - The in progress queue: a list of nodes whose arguments are being computed, - and thus can be computed at a later date, kept sorted by increasing - availability date - - The branch list: a list of all branch instructions (to be emitted last) *) - -let ready_queue = ref ([] : code_dag_node list) -let in_progress_queue = ref ([] : code_dag_node list) -let branch_list = ref ([] : code_dag_node list) (* built in reverse order *) - -let clear_queues () = - ready_queue := []; in_progress_queue := []; branch_list := [] - -let rec insert_queue prio node = function - [] -> [node] - | hd :: tl as queue -> - if prio node hd then node :: queue else hd :: insert_queue prio node tl - -let length_prio n1 n2 = n1.length > n2.length -let date_prio n1 n2 = n1.date < n2.date - -let add_ready node = - ready_queue := insert_queue length_prio node !ready_queue -let add_in_progress node = - in_progress_queue := insert_queue date_prio node !in_progress_queue -let add_branch node = - branch_list := node :: !branch_list - -(* Add an edge to the code DAG *) - -let add_edge ancestor son delay = - ancestor.sons <- (son, delay) :: ancestor.sons; - son.ancestors <- son.ancestors + 1 - -let add_edge_after son ancestor = add_edge ancestor son 0 - -(* Add an instruction to the code DAG *) - -let insimm opc arg imm res = - let instr = - try - Hashtbl.find instruction_table opc - with Not_found -> - fatal_error ("Unknown instruction " ^ opc) in - let node = - { instr = instr; - imm = imm; - iarg = arg; - ires = res; - delay = instr.latency; - sons = []; (* to be filled later *) - date = 0; (* to be adjusted later *) - length = -1; (* to be computed later *) - ancestors = 0; (* ditto *) - emitted_ancestors = 0 } in (* ditto *) - (* RAW dependencies: add edges from all instrs that define one of the - resources used *) - for i = 0 to Array.length arg - 1 do - try - let rsrc = arg.(i) in - if is_mutable_resource rsrc then begin - let anc = Hashtbl.find code_results rsrc in - let delay = if is_memory_resource rsrc then 0 else anc.delay in - (* Memory accesses are ordered by the hardware, so we can emit - a memop 1, then a dependent memop 2 in the same cycle *) - add_edge anc node delay - end - with Not_found -> - () - done; - (* WAR dependencies: add edges from all instrs that use one of the - resources defined by this instruction - WAW dependencies: add edges from all instrs that define one of the - resources defined by this instruction *) - for i = 0 to Array.length res - 1 do - let rsrc = res.(i) in - if is_mutable_resource rsrc then begin - (* WAR *) - let anc = Hashtbl.find_all code_uses res.(i) in - List.iter (add_edge_after node) anc; - (* WAW *) - try - let anc = Hashtbl.find code_results rsrc in - let delay = if is_memory_resource rsrc then 0 else 1 in - add_edge anc node delay - with Not_found -> - () - end - done; - (* Remember the results and uses of this instruction *) - for i = 0 to Array.length res - 1 do - Hashtbl.add code_results res.(i) node - done; - for i = 0 to Array.length arg - 1 do - Hashtbl.add code_uses arg.(i) node - done; - (* Insert in appropriate queue *) - if node.instr.kind = KB - then add_branch node - else if node.ancestors = 0 then add_ready node - -let insert opc arg res = - insimm opc arg "" res - -(* Compute length of longest path to a result. *) - -let rec longest_path node = - if node.length < 0 then begin - node.length <- - List.fold_left - (fun len (son, delay) -> max len (longest_path son + delay)) - 0 node.sons - end; - node.length - -(* Emit the assembly code for a node *) - -let emit_r = emit_string - -let emit_instr node = - let opc = node.instr.opcode - and a = node.iarg - and r = node.ires - and imm = node.imm in - match node.instr.format with - F_i -> - ` {emit_string opc} {emit_string imm}\n` - | F_i_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_string imm}\n` - | F_ir_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_string imm}, {emit_r a.(0)}\n` - | F_ir_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(0)}\n` - | F_ir_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(1)}\n` - | F_ld -> - ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}]\n` - | F_ld_post -> - ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}], {emit_string imm}\n` - | F_r -> - ` {emit_string opc} {emit_r a.(0)}\n` - | F_i_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` - | F_i_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` - | F_ri_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_string imm}\n` - | F_ri_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}\n` - | F_r_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}\n` - | F_r_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}\n` - | F_rr_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_r a.(1)}\n` - | F_r_rir -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}, {emit_r a.(1)}\n` - | F_rr_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}\n` - | F_rr_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}\n` - | F_rri_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_string imm}\n` - | F_rrr_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_r a.(2)}\n` - | F_rrr_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}, {emit_r a.(3)}\n` - | F_st -> - ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}\n` - | F_st_post -> - ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}, {emit_string imm}\n` - -(* Little state machine reflecting how many instructions the chip can - issue in one cycle. We roughly follow the Itanium model: - 2 int units, 2 mem units, 2 FP units, and 3 branch units, - with a maximum of 6 instructions dispatched per clock cycle. *) - -let num_A = ref 0 -let num_I = ref 0 -let num_M = ref 0 -let num_F = ref 0 -let num_B = ref 0 - -let reset_issue () = - num_A := 0; num_I := 0; num_M := 0; num_F := 0; num_B := 0 - -let can_issue instr = - if !num_A + !num_I + !num_M + !num_F + !num_B >= 6 then false else begin - match instr.kind with - KA -> - if !num_A + !num_I + !num_M < 4 - then (incr num_A; true) - else false - | KF -> - if !num_F < 2 then (incr num_F; true) else false - | KI -> - if !num_I < 2 && !num_A + !num_I + !num_M < 4 - then (incr num_I; true) else false - | KM -> - if !num_M < 2 && !num_A + !num_I + !num_M < 4 - then (incr num_M; true) else false - | _ (* KB | KB_exc *) -> - if !num_B < 3 then (incr num_B; true) else false - end - -(* Emit one node, updating the completion date and number of ancestors - emitted for all nodes that depend on this node. Enter the nodes - that are no longer waiting on anything (all ancestors emitted) - in the ready queue or in the in_progress queue, depending on - latency. *) - -let emit_node date node = - begin try - (*`# Date: {emit_int date}; distance: {emit_int node.length}\n`;*) - emit_instr node - with x -> - fatal_error ("Error while emitting " ^ node.instr.opcode) - end; - List.iter - (fun (son, delay) -> - let completion_date = date + delay in - if son.date < completion_date then son.date <- completion_date; - son.emitted_ancestors <- son.emitted_ancestors + 1; - if son.emitted_ancestors = son.ancestors && son.instr.kind <> KB then - begin - (*`# {emit_string son.instr.opcode} will be ready at {emit_int son.date}\n`;*) - if son.date = date then add_ready son else add_in_progress son - end) - node.sons - -(* Emit all ready nodes that we can emit given the architectural - constraints. *) - -let rec emit_ready_nodes filter date = - match !ready_queue with - [] -> [] - | node :: rem -> - ready_queue := rem; - if filter node && can_issue node.instr then begin - emit_node date node; - emit_ready_nodes filter date - end else - node :: emit_ready_nodes filter date - -let filter_MF node = - match node.instr.kind with KM -> true | KF -> true | _ -> false -let filter_non_MF node = - not(filter_MF node) - -(* Add all instructions with date <= d to the ready queue, and remove them *) - -let rec extract_ready d = function - [] -> [] - | node :: rem as queue -> - if node.date <= d then (add_ready node; extract_ready d rem) else queue - -(* Say if a branch is ready to be emitted now *) - -let branch_is_ready date br = - br.emitted_ancestors = br.ancestors && br.date <= date - -(* Schedule the basic block, emitting all of its instructions *) - -let rec reschedule date = - match (!ready_queue, !in_progress_queue) with - ([], []) -> - (* We're done with the regular instructions; finish with the branches *) - begin match !branch_list with - [] -> () - | br -> List.iter emit_instr br; emit_string " ;;\n" - end - | ([], node :: _) -> - (* Advance to the time node.date, extracting from in_progress_queue - all instructions ready at that time and adding them to the - ready queue *) - in_progress_queue := extract_ready node.date !in_progress_queue; - (* Try again *) - reschedule node.date - | (_, _) -> - ` # time {emit_int date}\n`; - (* Emit and remove as many ready instructions as we can *) - (* Give priority to M and F instructions *) - reset_issue(); - ready_queue := emit_ready_nodes filter_MF date; - ready_queue := emit_ready_nodes filter_non_MF date; - (* Special hack: if the only remaining instructions are branches - and they are all ready now, emit them in the current - group of instructions *) - if !ready_queue = [] - && !in_progress_queue = [] - && List.for_all (branch_is_ready date) !branch_list - then begin - List.iter emit_instr !branch_list; - branch_list := [] - end; - (* Emit a stop to pause the processor *) - emit_string " ;;\n"; - (* Advance to the time date + 1, extracting from in_progress_queue - all instructions ready at that time and adding them to the - ready queue *) - in_progress_queue := extract_ready (date + 1) !in_progress_queue; - (* Try again *) - reschedule (date + 1) - -(* Emit the code for the current basic block *) - -let end_basic_block () = - (* Compute critical paths and rebuild ready queue sorted by - decreasing criticality *) - let r = !ready_queue in - ready_queue := []; - let max_length = - List.fold_left (fun len node -> max len (longest_path node)) 0 r in - List.iter add_ready r; - branch_list := List.rev !branch_list; - (* Emit the instructions by traversing the code DAG *) - reschedule 0; - if max_length > 0 then ` # basic block length {emit_int max_length}\n`; - clear_code_dag (); - clear_queues () - -(************** Part 2: the code emitter *******************) - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Translate or output a label *) - -let label lbl = sprintf ".L%d" lbl - -let emit_label lbl = emit_string ".L"; emit_int lbl - -(* Translate or output a symbol *) - -let symbol s = - let b = Buffer.create (String.length s + 1) in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match c with - 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> - Buffer.add_char b c - | _ -> - Buffer.add_string b (sprintf "$%02x" (Char.code c)) - done; - Buffer.add_char b '#'; - Buffer.contents b - -let emit_symbol s = Emitaux.emit_symbol '$' s - -(* Translate a pseudo-register *) - -let reg r = - match r.loc with Reg r -> register_name r | _ -> assert false - -let regs r = - Array.map reg r - -(* Output a pseudo-register *) - -let emit_reg r = - match r.loc with - Reg r -> emit_string (register_name r) - | _ -> fatal_error "Emit_ia64.emit_reg" - -(* Translate a float as a 64-bit integer *) - -let float_bits f = - let b = Buffer.create 18 in - let bytes = (Obj.magic f : string) in - Buffer.add_string b "0x"; - for i = 7 downto 0 do (* little-endian *) - Buffer.add_string b - (sprintf "%02x" (Char.code (String.unsafe_get bytes i))) - done; - Buffer.contents b - -(* Translate an "ltoffset" reference to a global *) - -let ltoffset s = sprintf "@ltoff(%s)" (symbol s) -let ltoffset_fptr s = sprintf "@ltoff(@fptr(%s))" (symbol s) - -(* Layout of the stack frame. - All stack offsets are shifted by 16 to preserve the scratch area at - bottom of stack. *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + - (if !contains_calls then 8 else 0) in - Misc.align size 16 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n + 16 - | Local n -> - if cl = 0 - then !stack_offset + n * 8 + 16 - else !stack_offset + (num_stack_slots.(0) + n) * 8 + 16 - | Outgoing n -> n + 16 - -let slot_offset_reg r = - match r.loc with - Stack l -> slot_offset l (register_class r) - | _ -> assert false - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - lbl - -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:` - -let emit_frame fd = - ` data8 {emit_label fd.fd_lbl}\n`; - ` data2 {emit_int fd.fd_frame_size}\n`; - ` data2 {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` data2 {emit_int n}\n`) - fd.fd_live_offset; - ` .align 8\n` - -(* Names of various instructions *) - -let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "shl" - | Ilsr -> "shru" - | Iasr -> "shr" - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "fneg" - | Iabsf -> "fabs" - | Iaddf -> "fadd.d" - | Isubf -> "fsub.d" - | Imulf -> "fmpy.d" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -let name_for_specific_operation = function - Imultaddf -> "fma.d" - | Imultsubf -> "fms.d" - | Isubmultf -> "fnma.d" - | _ -> Misc.fatal_error "Emit.name_for_specific_operation" - -let name_for_int_comparison = function - Isigned Ceq -> "eq" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "gt" - | Isigned Clt -> "lt" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gtu" - | Iunsigned Clt -> "ltu" | Iunsigned Cge -> "geu" - -let name_for_swapped_int_comparison = function - Isigned Ceq -> "eq" | Isigned Cne -> "ne" - | Isigned Cle -> "ge" | Isigned Cgt -> "lt" - | Isigned Clt -> "gt" | Isigned Cge -> "le" - | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "geu" | Iunsigned Cgt -> "ltu" - | Iunsigned Clt -> "gtu" | Iunsigned Cge -> "leu" - -let name_for_float_comparison cmp = - match cmp with - Ceq -> "eq" | Cne -> "neq" - | Cle -> "le" | Cgt -> "gt" - | Clt -> "lt" | Cge -> "ge" - -(* Immediate range for addl (move) and adds (general add) instructions *) - -let is_immediate_addl n = n >= -0x200000 && n < 0x200000 -let is_immediate_addl_nat n = - n >= Nativeint.of_int (-0x200000) && n < Nativeint.of_int 0x200000 -let is_immediate_adds n = n >= -0x2000 && n < 0x2000 - -(* Return the positions of all "1" bits in the given integer, - most significant bits first *) - -let ones_pos n = - let rec ones p accu = - if p >= 63 - then accu - else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in - ones 0 [] - -(* Generate temporary registers *) - -let temp_generator temporaries = - let counter = ref 0 in - fun () -> - let r = temporaries.(!counter) in - incr counter; - if !counter >= Array.length temporaries then counter := 0; - r - -let new_temp_reg = - temp_generator [| "r2"; "r3"; "r14"; "r15" |] -let new_temp_float = - temp_generator [| "f64"; "f65"; "f66"; "f67"; - "f68"; "f69"; "f70"; "f71" |] -let new_pred = - temp_generator [| "p2"; "p3"; "p4"; "p5" |] - -(* 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 - -let emit_instr i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src.loc, dst.loc) with - (Reg _, Reg _) -> - insert "mov" (regs i.arg) (regs i.res) - | (Reg _, Stack _) -> - let offset = string_of_int (slot_offset_reg dst) in - let r = new_temp_reg() in - insimm "addi" [| "sp" |] offset [| r |]; - insert (if i.res.(0).typ = Float then "stfd" else "st8") - [| r; reg src |] [| "stk" ^ offset |] - | (Stack _, Reg _) -> - let offset = string_of_int (slot_offset_reg src) in - let r = new_temp_reg() in - insimm "addi" [| "sp" |] offset [| r |]; - insert (if i.arg.(0).typ = Float then "ldfd" else "ld8") - [| r; "stk" ^ offset |] (regs i.res) - | (_, _) -> - assert false - end - | Lop(Iconst_int n) -> - let instr = - if is_immediate_addl_nat n then "movi" else "movil" in - insimm instr [||] (Nativeint.to_string n) (regs i.res) - | Lop(Iconst_float s) -> - let f = float_of_string s in - begin match Int64.bits_of_float f with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - insert "mov" [| "f0" |] (regs i.res) - | 0x3FF0_0000_0000_0000L -> (* 1.0 *) - insert "mov" [| "f1" |] (regs i.res) - | _ -> - let tmp = new_temp_reg() in - insimm "movil" [||] (float_bits f) [| tmp |]; - insert "setf.d" [| tmp |] (regs i.res) - end - | Lop(Iconst_symbol s) -> - insimm "addi" [| "gp" |] (ltoffset s) (regs i.res); - insert "ld8" (regs i.res) (regs i.res) - | Lop(Icall_ind) -> - insert "movtb" (regs i.arg) [| "b0" |]; - insert "brcallind" [| "b0" |] [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - insimm "brcall" [||] (symbol s) [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - insert "movtb" (regs i.arg) [| "b6" |]; - if !contains_calls then begin - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "mov" [| tmp |] [| "b0" |] - end; - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insert "brind" [| "b6" |] [||]; - end_basic_block() - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - insimm "br" [||] (label !tailrec_entry_point) [||] - end else begin - let n = frame_size() in - if !contains_calls then begin - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "mov" [| tmp |] [| "b0" |] - end; - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insimm "br" [||] (symbol s) [||] - end; - end_basic_block() - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - let tmp = new_temp_reg() in - insimm "addi" [| "gp" |] (ltoffset_fptr s) [| tmp |]; - insert "ld8" [| tmp |] [| "r2" |]; - insimm "brcall" [||] "caml_c_call#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - end else begin - insert "mov" [| "gp" |] [| "r7" |]; - insimm "brcall" [||] (symbol s) [| "b0" |]; - end_basic_block(); - insert "mov" [| "r7" |] [| "gp" |] - end - | Lop(Istackoffset n) -> - end_basic_block(); - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let load_instr = - match chunk with - | Byte_unsigned -> "ld1" - | Byte_signed -> "ld1" - | Sixteen_unsigned -> "ld2" - | Sixteen_signed -> "ld2" - | Thirtytwo_unsigned -> "ld4" - | Thirtytwo_signed -> "ld4" - | Word -> "ld8" - | Single -> "ldfs" - | Double -> "ldfd" - | Double_u -> "ldfd" in - insert load_instr [| reg i.arg.(0); "heap" |] (regs i.res); - let sext_instr = - match chunk with - Byte_signed -> "sxt1" - | Sixteen_signed -> "sxt2" - | Thirtytwo_signed -> "sxt4" - | _ -> "" in - if sext_instr <> "" then - insert sext_instr (regs i.res) (regs i.res) - | Lop(Istore(chunk, addr)) -> - let store_instr = - match chunk with - | Byte_unsigned -> "st1" - | Byte_signed -> "st1" - | Sixteen_unsigned -> "st2" - | Sixteen_signed -> "st2" - | Thirtytwo_unsigned -> "st4" - | Thirtytwo_signed -> "st4" - | Word -> "st8" - | Single -> "stfs" - | Double -> "stfd" - | Double_u -> "stfd" in - insert store_instr [| reg i.arg.(1); reg i.arg.(0) |] [| "heap" |] - | Lop(Ialloc n) -> - if !fastcode_flag then begin - insimm "addi" [| "r4" |] (string_of_int (-n)) [| "r4" |]; - insert "cmp.ltu" [| "r4"; "r5" |] [| "p6"; "p0" |]; - insimm "movi" [||] (string_of_int n) [| "r2" |]; - insimm "brcallcond" [| "p6" |] "caml_call_gc#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n`; - insimm "addi" [| "r4" |] "8" (regs i.res) - end else begin - insimm "movi" [||] (string_of_int n) [| "r2" |]; - insimm "brcall" [||] "caml_allocN#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n`; - insimm "addi" [| "r4" |] "8" (regs i.res) - end - | Lop(Iintop Imul) -> - let t1 = new_temp_float() and t2 = new_temp_float() in - insert "setf.sig" [|reg i.arg.(0)|] [| t1 |]; - insert "setf.sig" [|reg i.arg.(1)|] [| t2 |]; - insert "xmpy.l" [| t1; t2 |] [| t1 |]; - insert "getf.sig" [| t1 |] (regs i.res) - | Lop(Iintop(Icomp cmp)) -> - let comp = "cmpp." ^ name_for_int_comparison cmp in - let p1 = new_pred() and p2 = new_pred() in - insert comp (regs i.arg) [| p1; p2 |]; - insimm "movicond" [| p1 |] "1" (regs i.res); - insimm "movicond" [| p2 |] "0" (regs i.res) - | Lop(Iintop(Icheckbound)) -> - insert "cmp.leu" (regs i.arg) [| "p6"; "p0" |]; - insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" - [| "b0"; "heap" |] - | Lop(Iintop op) -> - let instr = name_for_int_operation op in - insert instr (regs i.arg) (regs i.res) - | Lop(Iintop_imm(Imul, n)) -> - let src = reg i.arg.(0) and dst = reg i.res.(0) in - begin match ones_pos n with - [] -> - insimm "movi" [||] "0" [|dst|] - | [n] -> - insimm "shli" [|src|] (string_of_int n) [|dst|] - | [n; 0] when n <= 4 -> - insimm "shladd" [|src; src|] (string_of_int n) [|dst|] - | n1::n2::lst -> - let acc1 = new_temp_reg() and acc2 = new_temp_reg() - and tmp1 = new_temp_reg() and tmp2 = new_temp_reg() in - insimm "shli" [|src|] (string_of_int n1) [|acc1|]; - insimm "shli" [|src|] (string_of_int n2) [|acc2|]; - let rec add_shifts a1 t1 a2 t2 = function - [] -> - insert "add" [|a1; a2|] [|dst|] - | n::rem -> - if n = 0 then - insert "add" [|src; a1|] [|a1|] - else if n <= 4 then - insimm "shladd" [|src; a1|] (string_of_int n) [|a1|] - else begin - insimm "shli" [|src|] (string_of_int n) [|t1|]; - insert "add" [|t1; a1|] [|a1|] - end; - add_shifts a2 t2 a1 t1 rem in - add_shifts acc1 tmp1 acc2 tmp2 lst - end - | Lop(Iintop_imm(Idiv, n)) -> (* n must be a power of 2 *) - let src = regs i.arg and dst = regs i.res in - let p1 = new_pred() and p2 = new_pred() in - let l = Misc.log2 n in - insert "cmpp.lt" [| src.(0); "r0" |] [| p1; p2 |]; - if is_immediate_adds (n-1) then - insimm "addicond" [| p1; src.(0) |] (string_of_int (n-1)) dst - else begin - let moveop = if is_immediate_addl (n-1) then "movi" else "movil" in - insimm moveop [||] (string_of_int (n-1)) [| "r2" |]; - insert "addcond" [| p1; src.(0); "r2" |] dst - end; - insert "movcond" [| p2; src.(0) |] dst; - insimm "shri" dst (string_of_int l) dst - | Lop(Iintop_imm(Imod, n)) -> (* n must be a power of 2 *) - let src = regs i.arg and dst = regs i.res in - let p = new_pred() in - let l = Misc.log2 n in - insert "cmpp.lt" [| src.(0); "r0" |] [| p; "p0" |]; - insimm "extr.u" src (sprintf "0, %d" l) dst; - insert "cmpp.ne.and" [| dst.(0); "r0"; p |] [| p; "p0" |]; - if is_immediate_adds (-n) then - insimm "addicond" [| p; dst.(0) |] (string_of_int (-n)) dst - else begin - let moveop = if is_immediate_addl (-n) then "movi" else "movil" in - insimm moveop [||] (string_of_int (-n)) [| "r2" |]; - insert "addcond" [| p; dst.(0); "r2" |] dst - end - | Lop(Iintop_imm(Icomp cmp, n)) -> - let comp = "cmppi." ^ name_for_swapped_int_comparison cmp in - let p1 = new_pred() and p2 = new_pred() in - insimm comp (regs i.arg) (string_of_int n) [| p1; p2 |]; - insimm "movicond" [| p1 |] "1" (regs i.res); - insimm "movicond" [| p2 |] "0" (regs i.res) - | Lop(Iintop_imm(Icheckbound, n)) -> - insimm "cmpi.geu" (regs i.arg) (string_of_int n) [| "p6"; "p0" |]; - insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" - [| "b0"; "heap" |] - | Lop(Iintop_imm(op, n)) -> - let instr = name_for_int_operation op ^ "i" in - insimm instr (regs i.arg) (string_of_int n) (regs i.res) - | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf as op) -> - let instr = name_for_float_operation op in - insert instr (regs i.arg) (regs i.res) - | Lop(Idivf) -> - (* Straight from the IA64 application developer's architecture guide, - section 13.3.3.1. Modified so that the destination may be equal - to one of the operands *) - let a = reg i.arg.(0) and b = reg i.arg.(1) and r = reg i.res.(0) - and t1 = new_temp_float() and t2 = new_temp_float() - and t3 = new_temp_float() and t4 = new_temp_float() - and p = new_pred() in - insert "frcpa" [| a; b |] [| t1; p |]; - insert "fmas1cond" [| p; a; t1; "f0" |] [| t2 |]; - insert "fnmas1cond" [| p; b; t1; "f1" |] [| t3 |]; - insert "fmas1cond" [| p; t3; t3; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t3; t3; "f0" |] [| t4 |]; - insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; - insert "fmas1cond" [| p; t4; t2; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t4; t4; "f0" |] [| t3 |]; - insert "fmas1cond" [| p; t4; t1; t1 |] [| t1 |]; - insert "fmads1cond" [| p; t3; t2; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; - insert "fnmads1cond" [| p; b; t2; a |] [| t3 |]; - insert "mov" [| t1 |] [| r |]; - insert "fmacond" [| p; t3; t1; t2 |] [| r |] - | Lop(Ifloatofint) -> - let src = regs i.arg and dst = regs i.res in - insert "setf.sig" src dst; - insert "fcvt.xf" dst dst; - insert "fnorm.d" dst dst - | Lop(Iintoffloat) -> - let src = regs i.arg and dst = regs i.res and tmp = new_temp_float() in - insert "fcvt.fx.trunc" src [| tmp |]; - insert "getf.sig" [| tmp |] dst - | Lop(Ispecific(Iadd1)) -> - let s = if Array.length i.arg >= 2 then 1 else 0 in - insimm "add1" [| reg i.arg.(0); reg i.arg.(s) |] "1" (regs i.res) - | Lop(Ispecific(Isub1)) -> - insimm "sub1" (regs i.arg) "1" (regs i.res) - | Lop(Ispecific(Ishladd n)) -> - insimm "shladd" (regs i.arg) (string_of_int n) (regs i.res) - | Lop(Ispecific(Isignextend n)) -> - let op = "sxt" ^ string_of_int n in - insert op (regs i.arg) (regs i.res) - | Lop(Ispecific (Imultaddf | Imultsubf | Isubmultf as sop)) -> - let name = name_for_specific_operation sop in - insert name (regs i.arg) (regs i.res) - | Lop(Ispecific (Istoreincr n)) -> - let op = if i.arg.(1).typ = Float then "stfd+" else "st8+" in - insimm op [| reg i.arg.(0); reg i.arg.(1) |] - (string_of_int n) - [| reg i.res.(0); "heapinit" |] - | Lop(Ispecific Iinitbarrier) -> - insert "#initbarrier" [| "heapinit" |] [| "heap" |] - | Lreloadretaddr -> - let n = frame_size() + 8 in - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int n) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "movtb" [| tmp |] [| "b0" |] - | Lreturn -> - let n = frame_size() in - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insert "brret" [| "b0" |] [||]; - end_basic_block() - | Llabel lbl -> - end_basic_block(); - `{emit_label lbl}:\n` - | Lbranch lbl -> - insimm "br" [||] (label lbl) [||]; - end_basic_block() - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - insimm "cmpi.ne" (regs i.arg) "0" [| "p6"; "p0" |] - | Ifalsetest -> - insimm "cmpi.eq" (regs i.arg) "0" [| "p6"; "p0" |] - | Iinttest cmp -> - let comp = "cmp." ^ name_for_int_comparison cmp in - insert comp (regs i.arg) [| "p6"; "p0" |] - | Iinttest_imm(cmp, n) -> - let comp = "cmpi." ^ name_for_swapped_int_comparison cmp in - insimm comp (regs i.arg) (string_of_int n) [| "p6"; "p0" |] - | Ifloattest(cmp, neg) -> - let comp = "fcmp." ^ name_for_float_comparison cmp in - insert comp (regs i.arg) - (if neg then [| "p0"; "p6" |] - else [| "p6"; "p0" |]) - | Ioddtest -> - insimm "tbit.nz" (regs i.arg) "0" [| "p6"; "p0" |] - | Ieventest -> - insimm "tbit.z" (regs i.arg) "0" [| "p6"; "p0" |] - end; - insimm "brcond" [| "p6" |] (label lbl) [||]; - end_basic_block() - | Lcondbranch3(lbl0, lbl1, lbl2) -> - end_basic_block(); - let emit_compare n p = function - None -> () - | Some lbl -> - ` cmp.eq p{emit_int p}, p0 = {emit_int n}, {emit_reg i.arg.(0)}\n` in - let emit_branch p = function - None -> () - | Some lbl -> - ` (p{emit_int p}) br {emit_label lbl}\n` in - emit_compare 0 5 lbl0; emit_compare 1 6 lbl1; emit_compare 2 7 lbl2; - emit_branch 5 lbl0; emit_branch 6 lbl1; emit_branch 7 lbl2; - ` ;;\n` - | Lswitch jumptbl -> - end_basic_block(); - let numcases = Array.length jumptbl in - if numcases <= 9 then begin - for j = 0 to numcases / 3 do - let n = j * 3 in - for k = 0 to 2 do - if n + k < numcases - 1 then - ` cmp.eq p{emit_int(k+5)}, p0 = {emit_int (n+k)}, {emit_reg i.arg.(0)}\n` - done; - for k = 0 to 2 do - if n + k < numcases - 1 then - ` (p{emit_int(k+5)}) br {emit_label jumptbl.(n+k)}\n` - else if n + k = numcases - 1 then - ` br {emit_label jumptbl.(n+k)}\n` - done; - ` ;;\n` - done - end else if numcases <= 47 then begin - ` mov r2 = 1\n`; - ` cmp.eq p6, p0 = 0, {emit_reg i.arg.(0)}\n`; - ` (p6) br {emit_label jumptbl.(0)} ;;\n`; - ` shl r2 = r2, {emit_reg i.arg.(0)}\n`; - ` cmp.eq p7, p0 = 1, {emit_reg i.arg.(0)}\n`; - ` (p7) br {emit_label jumptbl.(1)} ;;\n`; - ` mov pr = r2, -1 ;;\n`; - for i = 2 to numcases - 1 do - ` (p{emit_int i}) br {emit_label jumptbl.(i)}\n` - done; - ` ;;\n` - end else begin - let lbl_jumptbl = new_label() in - let lbl_ip = new_label() in - `{emit_label lbl_ip}: mov r2 = ip ;;\n`; - ` add r2 = {emit_label lbl_jumptbl} - {emit_label lbl_ip}, r2 ;;\n`; - ` shladd r3 = {emit_reg i.arg.(0)}, 2, r2 ;;\n`; - ` ld4 r3 = [r3] ;;\n`; - ` sxt4 r3 = r3 ;;\n`; - ` add r2 = r2, r3 ;;\n`; - ` mov b6 = r2 ;;\n`; - ` br b6 ;;\n`; - ` .align 4\n`; - `{emit_label lbl_jumptbl}:\n`; - for i = 0 to numcases - 1 do - ` data4 {emit_label jumptbl.(i)} - {emit_label lbl_jumptbl}\n` - done; - ` .align 16\n` - end - | Lsetuptrap lbl -> - end_basic_block(); - let lbl_ip = new_label() in - let lbl_next = new_label() in - `{emit_label lbl_ip}: mov r2 = ip ;;\n`; - ` add r2 = {emit_label lbl_next} - {emit_label lbl_ip}, r2\n`; - ` br.sptk {emit_label lbl} ;;\n`; - `{emit_label lbl_next}:\n` - | Lpushtrap -> - end_basic_block(); - stack_offset := !stack_offset + 16; - (* Store trap pointer at sp, handler addr at sp+8, - and decrement sp by 16. Remember, the bottom 16 bytes - of the stack must be left free. *) - ` add r3 = 8, sp\n`; - ` st8 [sp] = r6, -16 ;;\n`; - ` st8 [r3] = r2\n`; - ` add r6 = 16, sp ;;\n` - | Lpoptrap -> - end_basic_block(); - ` add sp = 16, sp ;;\n`; - ` ld8 r6 = [sp] ;;\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - end_basic_block(); - ` mov sp = r6\n`; - ` add r2 = 8, r6\n`; - ` ld8 r6 = [r6] ;;\n`; - ` ld8 r2 = [r2] ;;\n`; - ` mov b6 = r2 ;;\n`; - ` br b6\n` - -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next - -(* Check if a function contains a tail call to itself *) - -let rec is_tailrec i = - match i.desc with - Lend -> false - | Lop(Itailcall_imm s) when s = !function_name -> true - | _ -> is_tailrec i.next - -(* Emission of a function declaration *) - -let fundecl f = - function_name := f.fun_name; - fastcode_flag := f.fun_fast; - stack_offset := 0; - ` .text\n`; - ` .align 4\n`; - ` .global {emit_symbol f.fun_name}#\n`; - ` .proc {emit_symbol f.fun_name}#\n`; - `{emit_symbol f.fun_name}:\n`; - let n = frame_size() in - if !contains_calls then begin - insert "movfb" [| "b0" |] [| "r2" |]; - insimm "addi" [| "sp" |] "8" [| "r3" |]; - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - insert "st8" [| "r3"; "r2" |] [||] - end - else if n > 0 then - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - if is_tailrec f.fun_body then begin - tailrec_entry_point := new_label(); - end_basic_block(); - `{emit_label !tailrec_entry_point}:\n` - end; - emit_all f.fun_body; - end_basic_block(); - ` .endp {emit_symbol f.fun_name}#\n` - -(* Emission of data *) - -let emit_global_symbol s = - ` .global {emit_symbol s}#\n`; - ` .type {emit_symbol s}#, @object\n`; - ` .size {emit_symbol s}#, 8\n` - -let emit_define_symbol s = - emit_global_symbol s; - `{emit_symbol s}:\n` - -let emit_item = function - Cglobal_symbol s -> - emit_global_symbol s - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` data1 {emit_int n}\n` - | Cint16 n -> - ` data2 {emit_int n}\n` - | Cint32 n -> - let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in - ` data4 {emit_nativeint n'}\n` - | Cint n -> - ` data8 {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive "data4" f - | Cdouble f -> - emit_float64_directive "data8" f - | Csymbol_address s -> - ` data8 {emit_symbol s}#\n` - | Clabel_address lbl -> - ` data8 {emit_label (100000 + lbl)}\n` - | Cstring s -> - emit_string_directive " string " s - | Cskip n -> - if n > 0 then ` .skip {emit_int n}\n` - | Calign n -> - ` .align {emit_int n}\n` - -let data l = - ` .data\n`; - ` .align 8\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - ` .data\n`; - emit_define_symbol (Compilenv.make_symbol (Some "data_begin")); - ` .text\n`; - emit_define_symbol (Compilenv.make_symbol (Some "code_begin")) - -let end_assembly () = - ` .data\n`; - emit_define_symbol (Compilenv.make_symbol (Some "data_end")); - ` .text\n`; - emit_define_symbol (Compilenv.make_symbol (Some "code_end")); - ` .rodata\n`; - ` .align 8\n`; - emit_define_symbol (Compilenv.make_symbol (Some "frametable")); - ` data8 {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml deleted file mode 100644 index 97ee3f3cc..000000000 --- a/asmcomp/ia64/proc.ml +++ /dev/null @@ -1,217 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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$ *) - -(* Description of the IA64 processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = false - -(* Registers available for register allocation *) - -(* Register map: - r0 always 0 - r1 global pointer (gp) - r2 - r3 temporaries (for the code generator) - r4 allocation pointer - r5 allocation limit - r6 trap pointer - r7 saved gp during C calls (preserved by C) - r8 - r11 0 - 3 function results - r12 stack pointer - r13 reserved by C (thread-specific data) - r14 - r15 80 - 81 temporaries (for accessing stack variables) - r16 - r31 4 - 19 general purpose - r32 - r63 20 - 51 function arguments - r64 - r91 52 - 79 general purpose - r92 - r95 used by C glue code - - We do not use register windows, but instead allocate 64 "out" registers - (r32-r95) when entering Caml code. - - f0 always 0.0 - f1 always 1.0 - f2 - f5 100 - 103 general purpose (preserved by C) - f6 - f7 104 - 105 general purpose - f8 - f15 106 - 113 function results - f16 - f31 114 - 129 function arguments (preserved by C) - f32 - f63 130 - 161 general purpose - f64 - f66 temporaries - f67 - f127 unused -*) - -let int_reg_name = [| - (* 0-3 *) "r8"; "r9"; "r10"; "r11"; - (* 4-19 *) "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23"; - "r24"; "r25"; "r26"; "r27"; "r28"; "r29"; "r30"; "r31"; - (* 20-51 *) "r32"; "r33"; "r34"; "r35"; "r36"; "r37"; "r38"; "r39"; - "r40"; "r41"; "r42"; "r43"; "r44"; "r45"; "r46"; "r47"; - "r48"; "r49"; "r50"; "r51"; "r52"; "r53"; "r54"; "r55"; - "r56"; "r57"; "r58"; "r59"; "r60"; "r61"; "r62"; "r63"; - (* 52-79 *) "r64"; "r65"; "r66"; "r67"; "r68"; "r69"; "r70"; "r71"; - "r72"; "r73"; "r74"; "r75"; "r76"; "r77"; "r78"; "r79"; - "r80"; "r81"; "r82"; "r83"; "r84"; "r85"; "r86"; "r87"; - "r88"; "r89"; "r90"; "r91"; - (* 80-81 *) "r14"; "r15" -|] - -let float_reg_name = [| - (* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; - "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; - (* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; - "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31"; - (* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39"; - "f40"; "f41"; "f42"; "f43"; "f44"; "f45"; "f46"; "f47"; - "f48"; "f49"; "f50"; "f51"; "f52"; "f53"; "f54"; "f55"; - "f56"; "f57"; "f58"; "f59"; "f60"; "f61"; "f62"; "f63" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 80; 62 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 82 Reg.dummy in - for i = 0 to 81 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 62 Reg.dummy in - for i = 0 to 61 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float - lockstep make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int; - if lockstep then incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float; - if lockstep then incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 20 51 114 129 false outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 20 51 114 129 false incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res - in loc -(* Arguments in r32...r39, f8...f15 - Results in r8...r11, f8...f15 *) -let loc_external_arguments arg = - calling_conventions 20 27 106 113 true outgoing arg -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res - in loc -let extcall_use_push = false - -let loc_exn_bucket = phys_reg 0 (* r8 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* f2...f5, f16...f31 preserved by C *) - Array.append - hard_int_reg - (Array.of_list(List.map phys_reg - [100;101;102;103;104;105;106;107;108;109;110;111;112;113; - 130;131;132;133;134;135;136;137;138;139; - 140;141;142;143;144;145;146;147;148;149; - 150;151;152;153;154;155;156;157;158;159; - 160;161])) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 0 - | _ -> 62 -let max_register_pressure = function - Iextcall(_, _) -> [| 0; 20 |] - | _ -> num_available_registers - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/ia64/reload.ml b/asmcomp/ia64/reload.ml deleted file mode 100644 index 09210b164..000000000 --- a/asmcomp/ia64/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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$ *) - -(* Reloading for the IA64. *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/ia64/scheduling.ml b/asmcomp/ia64/scheduling.ml deleted file mode 100644 index 6c696aca2..000000000 --- a/asmcomp/ia64/scheduling.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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$ *) - -open Schedgen (* to create a dependency *) - -(* We don't schedule here on the linearized code, but instead schedule the - assembly code generated in Emit. *) - -let fundecl f = f diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml deleted file mode 100644 index 0c16c346a..000000000 --- a/asmcomp/ia64/selection.ml +++ /dev/null @@ -1,178 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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$ *) - -(* Instruction selection for the IA64 processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Helper function for add selection *) - -let reassociate_add = function - [Cconst_int n; arg] -> - [arg; Cconst_int n] - | [Cop(Caddi, [arg1; Cconst_int n]); arg3] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [Cop(Caddi, [Cconst_int n; arg1]); arg3] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [arg1; Cop(Caddi, [Cconst_int n; arg3])] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [arg1; Cop(Caddi, [arg2; arg3])] -> - [Cop(Caddi, [arg1; arg2]); arg3] - | args -> args - -(* Helper function for mult-immediate selection *) - -let rec count_one_bits n = - if n = 0 then 0 - else if n land 1 = 0 then count_one_bits (n lsr 1) - else 1 + count_one_bits (n lsr 1) - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -(* Range of immediate arguments: - add 14-bit signed - sub turned into add - sub reversed 8-bit signed - mul at most 16 "one" bits - div, mod powers of 2 - and, or, xor 8-bit signed - lsl, lsr, asr 6-bit unsigned - cmp 8-bit signed - For is_immediate, we put 8-bit signed and treat adds specially - (selectgen already does the right thing for shifts) *) - -method is_immediate n = n >= -128 && n < 128 - -method is_immediate_add n = n >= -8192 && n < 8192 - -method select_addressing arg = (Iindexed, arg) - -method! select_operation op args = - let norm_op = - match op with Cadda -> Caddi | Csuba -> Csubi | _ -> op in - let norm_args = - match norm_op with Caddi -> reassociate_add args | _ -> args in - match (norm_op, norm_args) with - (* Recognize x + y + 1 and x - y - 1 *) - | (Caddi, [Cop(Caddi, [arg1; arg2]); Cconst_int 1]) -> - (Ispecific Iadd1, [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int 1]); Cconst_int 1]) -> - (Ispecific Iadd1, [arg1]) - | (Csubi, [Cop(Csubi, [arg1; arg2]); Cconst_int 1]) -> - (Ispecific Isub1, [arg1; arg2]) - | (Csubi, [Cop(Csubi, [arg1; Cconst_int 1]); arg2]) -> - (Ispecific Isub1, [arg1; arg2]) - (* Recognize add immediate *) - | (Caddi, [arg; Cconst_int n]) when self#is_immediate_add n -> - (Iintop_imm(Iadd, n), [arg]) - (* Turn sub immediate into add immediate *) - | (Csubi, [arg; Cconst_int n]) when self#is_immediate_add (-n) -> - (Iintop_imm(Iadd, -n), [arg]) - (* Recognize imm - arg *) - | (Csubi, [Cconst_int n; arg]) when self#is_immediate n -> - (Iintop_imm(Isub, n), [arg]) - (* Recognize shift-add operations *) - | (Caddi, [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)])]) -> - (Ispecific(Ishladd shift), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)]); arg2]) -> - (Ispecific(Ishladd shift), [arg1; arg2]) - (* Recognize truncation/normalization of 64-bit integers to 32 bits *) - | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> - (Ispecific (Isignextend 4), [arg]) - (* Recognize x * cst and cst * x *) - | (Cmuli, [arg; Cconst_int n]) -> - self#select_imul_imm arg n - | (Cmuli, [Cconst_int n; arg]) -> - self#select_imul_imm arg n - (* Prevent the recognition of (x / cst) and (x % cst) when cst is not - a power of 2, which do not correspond to an instruction. - Turn general division and modulus into calls to C library functions *) - | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> - (Iextcall("__divdi3", false), args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 -> - (Iintop_imm(Imod, n), [arg]) - | (Cmodi, _) -> - (Iextcall("__moddi3", false), args) - (* Recognize mult-add and mult-sub instructions *) - | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> - (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> - (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> - (Ispecific Imultsubf, [arg1; arg2; arg3]) - | (Csubf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> - (Ispecific Isubmultf, [arg1; arg2; arg3]) - (* Use default selector otherwise *) - | _ -> - super#select_operation op args - -method private select_imul_imm arg n = - if count_one_bits n <= 16 - then (Iintop_imm(Imul, n), [arg]) - else (Iintop Imul, [arg; Cconst_int n]) - -(* To palliate the lack of addressing with displacement, multiple - stores to the address r are translated as follows - (t1 and t2 are two temp regs) - t1 := r - 8 - t2 := r - compute data1 in reg1 - compute data2 in reg2 - store reg1 at t1 and increment t1 by 16 - store reg2 at t2 and increment t2 by 16 - compute data3 in reg3 - compute data4 in reg4 - store reg3 at t1 and increment t1 by 16 - store reg4 at t2 and increment t2 by 16 - ... - Note: we use two temp regs and perform stores by groups of 2 - in order to expose more instruction-level parallelism. *) -method! emit_stores env data regs_addr = - let t1 = Reg.create Addr and t2 = Reg.create Addr in - self#insert (Iop(Iintop_imm(Iadd, -8))) regs_addr [|t1|]; - self#insert (Iop Imove) regs_addr [|t2|]; - (* Store components by batch of 2 *) - let backlog = ref None in - let do_store r = - match !backlog with - None -> (* keep it for later *) - backlog := Some r - | Some r' -> (* store r' at t1 and r at t2 *) - self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r' |] [| t1 |]; - self#insert (Iop(Ispecific(Istoreincr 16))) [| t2; r |] [| t2 |]; - backlog := None in - List.iter - (fun exp -> - match self#emit_expr env exp with - None -> assert false - | Some regs -> Array.iter do_store regs) - data; - (* Store the backlog if any *) - begin match !backlog with - None -> () - | Some r -> self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r |] [| t1 |] - end; - (* Insert an init barrier *) - self#insert (Iop(Ispecific Iinitbarrier)) [||] [||] -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/m68k/README b/asmcomp/m68k/README deleted file mode 100644 index fe5479d45..000000000 --- a/asmcomp/m68k/README +++ /dev/null @@ -1,8 +0,0 @@ -As of Feb 4th 2000, the native-code compiler for the Motorola 680x0 is -no longer maintained and thus deprecated. - -The only machines on which we could test this port (Sun 3, SunOS 4) -here at INRIA are being retired, and were so slow that the port wasn't -kept up-to-date with the remainder of the system. - -- Xavier Leroy, for the Objective Caml development team. diff --git a/asmcomp/mips/arch.ml b/asmcomp/mips/arch.ml deleted file mode 100644 index af36f6f27..000000000 --- a/asmcomp/mips/arch.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Specific operations for the Mips processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Specific operations *) - -type specific_operation = unit (* none *) - -(* Sizes, endianness *) - -let big_endian = - match Config.system with - "ultrix" -> false - | "irix" -> true - | _ -> fatal_error "Arch_mips.big_endian" - -let size_addr = 4 -let size_int = 4 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "\"%s\"%s" s idx - | Iindexed n -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "%a%s" printreg arg.(0) idx - -let print_specific_operation printreg op ppf arg = - fatal_error "Arch_mips.print_specific_operation" diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp deleted file mode 100644 index 1abf9d599..000000000 --- a/asmcomp/mips/emit.mlp +++ /dev/null @@ -1,593 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Mips assembly code *) - -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 - -(* Output a label *) - -let emit_label lbl = - emit_string "$"; 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_mips.emit_reg" - -(* Record if $gp is needed *) - -let uses_gp = ref false - -(* Layout of the stack frame *) - -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 if !uses_gp then 8 else 4 else 0) in - Misc.align size 16 - -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 `{emit_int ofs}($sp)` - | _ -> fatal_error "Emit_mips.emit_stack" - -(* Output an addressing mode *) - -let emit_addressing addr r n = - match addr with - Iindexed ofs -> - `{emit_int ofs}({emit_reg r.(n)})` - | Ibased(s, 0) -> - `{emit_symbol s}` - | Ibased(s, ofs) -> - `{emit_symbol s}`; - if ofs > 0 then ` + {emit_int ofs}`; - if ofs < 0 then ` - {emit_int(-ofs)}` - -(* Communicate live registers at call points to the assembler *) - -let int_reg_number = - [| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |] - -let float_reg_number = - [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; - 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |] - -let liveregs instr extra_msk = - (* $22, $23, $30 always live *) - let int_mask = ref(0x00000302 lor extra_msk) - and float_mask = ref 0 in - let add_register = function - {loc = Reg r; typ = (Int | Addr)} -> - int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) - | {loc = Reg r; typ = Float} -> - float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) - | _ -> () in - Reg.Set.iter add_register instr.live; - Array.iter add_register instr.arg; - emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask - -let live_25 = 1 lsl (31 - 25) -let live_24 = 1 lsl (31 - 24) - -(* 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 := ((int_reg_number.(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}\n`; - ` .half {emit_int fd.fd_frame_size}\n`; - ` .half {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .half {emit_int n}\n`) - fd.fd_live_offset; - ` .align 2\n` - -(* Determine if $gp is used in the function *) - -let rec instr_uses_gp i = - match i.desc with - Lend -> false - | Lop(Iconst_symbol s) -> true - | Lop(Icall_imm s) -> true - | Lop(Itailcall_imm s) -> true - | Lop(Iextcall(_, _)) -> true - | Lop(Iload(_, Ibased(_, _))) -> true - | Lop(Istore(_, Ibased(_, _))) -> true - | Lop(Ialloc _) -> true - | Lop(Iintop(Icheckbound)) -> true - | Lop(Iintop_imm(Icheckbound, _)) -> true - | Lswitch jumptbl -> true - | _ -> instr_uses_gp i.next - -(* 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 -> "leu" - | Iunsigned Cge -> "geu" | Iunsigned Clt -> "ltu" | Iunsigned Cgt -> "gtu" - -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> ("eq", neg) | Cne -> ("eq", not neg) - | Cle -> ("le", neg) | Cge -> ("ult", not neg) - | Clt -> ("lt", neg) | Cgt -> ("ule", not neg) - -let name_for_int_operation = function - Iadd -> "addu" - | Isub -> "subu" - | Imul -> "mul" - | Idiv -> "div" - | Imod -> "rem" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sll" - | Ilsr -> "srl" - | Iasr -> "sra" - | Icomp cmp -> "s" ^ name_for_comparison cmp - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "neg.d" - | Iabsf -> "abs.d" - | Iaddf -> "add.d" - | Isubf -> "sub.d" - | Imulf -> "mul.d" - | Idivf -> "div.d" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -(* 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 jump to caml_call_gc *) -let call_gc_label = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 - -let emit_instr i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src, dst) with - {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> - ` move {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> - ` mov.d {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> - ` sw {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> - ` s.d {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> - ` lw {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> - ` l.d {emit_reg dst}, {emit_stack src}\n` - | _ -> - fatal_error "Emit_mips: Imove" - end - | Lop(Iconst_int n) -> - if n = 0n then - ` move {emit_reg i.res.(0)}, $0\n` - else - ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - ` li.d {emit_reg i.res.(0)}, {emit_string s}\n` - | Lop(Iconst_symbol s) -> - ` la {emit_reg i.res.(0)}, {emit_symbol s}\n` - | Lop(Icall_ind) -> - ` move $25, {emit_reg i.arg.(0)}\n`; - liveregs i live_25; - ` jal {emit_reg i.arg.(0)}\n`; - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - liveregs i 0; - ` jal {emit_symbol s}\n`; - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` lw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - liveregs i 0; - ` move $25, {emit_reg i.arg.(0)}\n`; - liveregs i live_25; - ` j {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - ` b {emit_label !tailrec_entry_point}\n` - end else begin - let n = frame_size() in - if !contains_calls then - ` lw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - ` la $25, {emit_symbol s}\n`; - liveregs i live_25; - ` j $25\n` - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` la $24, {emit_symbol s}\n`; - liveregs i live_24; - ` jal caml_c_call\n`; - `{record_frame i.live}\n` - end else begin - ` jal {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - if n >= 0 then - ` subu $sp, $sp, {emit_int n}\n` - else - ` addu $sp, $sp, {emit_int (-n)}\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - Double_u -> - (* Destination is not 8-aligned, hence cannot use l.d *) - ` ldl $24, {emit_addressing addr i.arg 0}\n`; - ` ldr $24, {emit_addressing (offset_addressing addr 7) i.arg 0}\n`; - ` dmtc1 $24, {emit_reg dest}\n` - | Single -> - ` l.s {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; - ` cvt.d.s {emit_reg dest}, {emit_reg dest}\n` - | _ -> - let load_instr = - match chunk with - Byte_unsigned -> "lbu" - | Byte_signed -> "lb" - | Sixteen_unsigned -> "lhu" - | Sixteen_signed -> "lh" - | Double -> "l.d" - | _ -> "lw" in - ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr)) -> - let src = i.arg.(0) in - begin match chunk with - Double_u -> - (* Destination is not 8-aligned, hence cannot use l.d *) - ` dmfc1 $24, {emit_reg src}\n`; - ` sdl $24, {emit_addressing addr i.arg 1}\n`; - ` sdr $24, {emit_addressing (offset_addressing addr 7) i.arg 1}\n` - | Single -> - ` cvt.s.d $f31, {emit_reg src}\n`; - ` s.s $f31, {emit_addressing addr i.arg 1}\n` - | _ -> - let store_instr = - match chunk with - Byte_unsigned | Byte_signed -> "sb" - | Sixteen_unsigned | Sixteen_signed -> "sh" - | Double -> "s.d" - | _ -> "sw" in - ` {emit_string store_instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n` - end - | Lop(Ialloc n) -> - if !call_gc_label = 0 then call_gc_label := new_label(); - ` .set noreorder\n`; - ` subu $22, $22, {emit_int n}\n`; - ` subu $24, $22, $23\n`; - ` bltzal $24, {emit_label !call_gc_label}\n`; - ` addu {emit_reg i.res.(0)}, $22, 4\n`; - `{record_frame i.live}\n`; - ` .set reorder\n` - | Lop(Iintop(Icheckbound)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label !range_check_trap}\n` - | 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` - | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` bleu {emit_reg i.arg.(0)}, {emit_int n}, {emit_label !range_check_trap}\n` - | 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` - | Lop(Inegf | Iabsf as op) -> - let instr = name_for_float_operation 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_float_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Ifloatofint) -> - ` mtc1 {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; - ` cvt.d.w {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintoffloat) -> - ` trunc.w.d $f31, {emit_reg i.arg.(0)}, $24\n`; - ` mfc1 {emit_reg i.res.(0)}, $f31\n` - | Lop(Ispecific sop) -> - fatal_error "Emit_mips: Ispecific" - | Lreloadretaddr -> - let n = frame_size() in - ` lw $31, {emit_int(n - 4)}($sp)\n`; - | Lreturn -> - let n = frame_size() in - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - liveregs i 0; - ` j $31\n` - | Llabel lbl -> - `{emit_label lbl}:\n` - | Lbranch lbl -> - ` b {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - ` bne {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - | Ifalsetest -> - ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - | Iinttest cmp -> - let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - let (comp, branch) = name_for_float_comparison cmp neg in - ` c.{emit_string comp}.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - if branch - then ` bc1f {emit_label lbl}\n` - else ` bc1t {emit_label lbl}\n` - | Ioddtest -> - ` and $24, {emit_reg i.arg.(0)}, 1\n`; - ` bne $24, $0, {emit_label lbl}\n` - | Ieventest -> - ` and $24, {emit_reg i.arg.(0)}, 1\n`; - ` beq $24, $0, {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` subu $24, {emit_reg i.arg.(0)}, 1\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` beq $24, $0, {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` bgtz $24, {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl_jumptbl = new_label() in - ` sll $24, {emit_reg i.arg.(0)}, 2\n`; - ` lw $24, {emit_label lbl_jumptbl}($24)\n`; - liveregs i live_24; - ` j $24\n`; - ` .rdata\n`; - `{emit_label lbl_jumptbl}:\n`; - for i = 0 to Array.length jumptbl - 1 do - ` .word {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` subu $sp, $sp, 16\n`; - ` bal {emit_label lbl}\n` - | Lpushtrap -> - stack_offset := !stack_offset + 16; - ` sw $30, 0($sp)\n`; - ` sw $31, 4($sp)\n`; - ` sw $gp, 8($sp)\n`; - ` move $30, $sp\n` - | Lpoptrap -> - ` lw $30, 0($sp)\n`; - ` addu $sp, $sp, 16\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - ` lw $25, 4($30)\n`; - ` move $sp, $30\n`; - ` lw $30, 0($sp)\n`; - ` lw $gp, 8($sp)\n`; - ` addu $sp, $sp, 16\n`; - liveregs i live_25; - ` jal $25\n` (* Keep retaddr in $31 for debugging *) - -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next - -(* Emission of a function declaration *) - -let fundecl fundecl = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - uses_gp := instr_uses_gp fundecl.fun_body; - if !uses_gp then contains_calls := true; - tailrec_entry_point := new_label(); - stack_offset := 0; - call_gc_label := 0; - range_check_trap := 0; - ` .text\n`; - ` .align 2\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - ` .ent {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - let n = frame_size() in - if n > 0 then - ` subu $sp, $sp, {emit_int n}\n`; - if !contains_calls then - ` sw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then begin - ` sw $gp, {emit_int(n - 8)}($sp)\n`; - ` lui $24, %hi(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; - ` addiu $24, $24, %lo(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; - ` daddu $gp, $25, $24\n` - end; - `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; - if !call_gc_label > 0 then begin - `{emit_label !call_gc_label}:\n`; - ` la $25, caml_call_gc\n`; - ` j $25\n` - end; - if !range_check_trap > 0 then begin - `{emit_label !range_check_trap}:\n`; - ` la $25, caml_ml_array_bound_error\n`; - ` j $25\n` - end; - ` .end {emit_symbol fundecl.fun_name}\n` - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .half {emit_int n}\n` - | Cint32 n -> - ` .word {emit_nativeint n}\n` - | Cint n -> - ` .word {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".word" f - | Cdouble f -> - emit_float64_split_directive ".word" f - | Csymbol_address s -> - ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_label (100000 + 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() = - (* There are really two groups of registers: - $sp and $30 always point to stack locations - $2 - $21 never point to stack locations. *) - ` .noalias $2,$sp; .noalias $2,$30; .noalias $3,$sp; .noalias $3,$30\n`; - ` .noalias $4,$sp; .noalias $4,$30; .noalias $5,$sp; .noalias $5,$30\n`; - ` .noalias $6,$sp; .noalias $6,$30; .noalias $7,$sp; .noalias $7,$30\n`; - ` .noalias $8,$sp; .noalias $8,$30; .noalias $9,$sp; .noalias $9,$30\n`; - ` .noalias $10,$sp; .noalias $10,$30; .noalias $11,$sp; .noalias $11,$30\n`; - ` .noalias $12,$sp; .noalias $12,$30; .noalias $13,$sp; .noalias $13,$30\n`; - ` .noalias $14,$sp; .noalias $14,$30; .noalias $15,$sp; .noalias $15,$30\n`; - ` .noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`; - ` .noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`; - ` .noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - ` .ent {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - ` .end {emit_symbol lbl_begin}\n` - -let end_assembly () = - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - ` .globl {emit_symbol lbl_end}\n`; - ` .ent {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .end {emit_symbol lbl_end}\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .data\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .word 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .rdata\n`; - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; - ` .word {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml deleted file mode 100644 index 9b2d84ae1..000000000 --- a/asmcomp/mips/proc.ml +++ /dev/null @@ -1,210 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Description of the Mips processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = false - -(* Registers available for register allocation *) - -(* Register map: - $0 always 0 - $1 temporary for the assembler - $2 - $7 0 - 5 function results - $8 - $15 6 - 13 function arguments - $16 - $21 14 - 19 general purpose (preserved by C) - $22 allocation pointer (preserved by C) - $23 allocation limit (preserved by C) - $24 - $25 temporaries - $26 - $29 kernel regs, stack pointer, global pointer - $30 trap pointer (preserved by C) - $31 return address - - $f0 - $f3 100 - 103 function results - $f4 - $f11 104 - 111 general purpose - $f12 - $f19 112 - 119 function arguments - $f20 - $f30 120 - 130 general purpose (even numbered preserved by C) - $f31 temporary *) - -let int_reg_name = [| - (* 0-5 *) "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; - (* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15"; - (* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21" -|] - -let float_reg_name = [| - "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; - "$f5"; "$f6"; "$f7"; "$f8"; "$f9"; - "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; - "$f15"; "$f16"; "$f17"; "$f18"; "$f19"; - "$f20"; "$f21"; "$f22"; "$f23"; "$f24"; - "$f25"; "$f26"; "$f27"; "$f28"; "$f29"; "$f30" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 20; 31 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 20 Reg.dummy in - for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 31 Reg.dummy in - for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float - make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 6 13 112 119 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 6 13 112 119 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 103 not_supported res in loc - -(* The C calling conventions are as follows: - the first 8 arguments are passed either in integer regs $4...$11 - or float regs $f12...$f19. Each argument "consumes" both one slot - in the int register file and one slot in the float register file. - Extra arguments are passed on stack, in a 64-bits slot, right-justified - (i.e. at +4 from natural address). *) - -let loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref 2 in - let float = ref 112 in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - if i < 8 then begin - loc.(i) <- phys_reg (if arg.(i).typ = Float then !float else !int); - incr int; - incr float - end else begin - begin match arg.(i).typ with - Float -> loc.(i) <- stack_slot (Outgoing !ofs) Float - | ty -> loc.(i) <- stack_slot (Outgoing (!ofs + 4)) ty - end; - ofs := !ofs + 8 - end - done; - (loc, Misc.align !ofs 16) - -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc - -let loc_exn_bucket = phys_reg 0 (* $2 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = - (* $16 - $21, $f20, $f22, $f24, $f26, $f28, $f30 preserved *) - Array.of_list(List.map phys_reg - [0;1;2;3;4;5;6;7;8;9;10;11;12;13; - 100;101;102;103;104;105;106;107;108;109;110;111;112;113;114; - 115;116;117;118;119;121;123;125;127;129]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 6 - | _ -> 20 -let max_register_pressure = function - Iextcall(_, _) -> [| 6; 6 |] - | _ -> [| 20; 31 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/mips/reload.ml b/asmcomp/mips/reload.ml deleted file mode 100644 index 2e9838bc9..000000000 --- a/asmcomp/mips/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -(* Reloading for the Mips *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/mips/scheduling.ml b/asmcomp/mips/scheduling.ml deleted file mode 100644 index 17b7e3883..000000000 --- a/asmcomp/mips/scheduling.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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$ *) - -open Schedgen (* to create a dependency *) - -(* No scheduling is needed for the Mips, the assembler - does it better than us. *) - -let fundecl f = f diff --git a/asmcomp/mips/selection.ml b/asmcomp/mips/selection.ml deleted file mode 100644 index 791fe296d..000000000 --- a/asmcomp/mips/selection.ml +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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$ *) - -(* Instruction selection for the Mips processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -class selector = object - -inherit Selectgen.selector_generic - -method is_immediate (n : int) = true - -method select_addressing = function - Cconst_symbol s -> - (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> - (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmrun/alpha.S b/asmrun/alpha.S deleted file mode 100644 index c726d4592..000000000 --- a/asmrun/alpha.S +++ /dev/null @@ -1,440 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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 GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Alpha processor */ - -/* Allocation */ - - .text - .globl caml_alloc2 - .globl caml_alloc3 - .globl caml_allocN - .globl caml_call_gc - -/* Note: the profiling code sets $27 to the address of the "normal" entrypoint. - So don't pass parameters to those routines in $27. */ - -/* caml_alloc* : all code generator registers preserved, - $gp preserved, $27 not necessarily valid on entry */ - - .globl caml_alloc1 - .ent caml_alloc1 - .align 3 -caml_alloc1: - .prologue 0 - subq $13, 16, $13 - cmpult $13, $14, $25 - bne $25, $100 - ret ($26) -$100: ldiq $25, 16 - br $110 - .end caml_alloc1 - - .globl caml_alloc2 - .ent caml_alloc2 - .align 3 -caml_alloc2: - .prologue 0 - subq $13, 24, $13 - cmpult $13, $14, $25 - bne $25, $101 - ret ($26) -$101: ldiq $25, 24 - br $110 - .end caml_alloc2 - - .globl caml_alloc3 - .ent caml_alloc3 - .align 3 -caml_alloc3: - .prologue 0 - subq $13, 32, $13 - cmpult $13, $14, $25 - bne $25, $102 - ret ($26) -$102: ldiq $25, 32 - br $110 - .end caml_alloc3 - - .globl caml_allocN - .ent caml_allocN - .align 3 -caml_allocN: - .prologue 0 - subq $13, $25, $13 - .set noat - cmpult $13, $14, $at - bne $at, $110 - .set at - ret ($26) - .end caml_allocN - - .globl caml_call_gc - .ent caml_call_gc - .align 3 -caml_call_gc: - .prologue 0 - ldiq $25, 0 -$110: lda $sp, -0x200($sp) - /* 0x200 = 32*8 (ints) + 32*8 (floats) */ - stq $26, 0x1F8($sp) /* return address */ - stq $gp, 0x1F0($sp) /* caller's $gp */ - stq $25, 0x1E8($sp) /* desired size */ - /* Rebuild $gp */ - br $27, $103 -$103: ldgp $gp, 0($27) - /* Record lowest stack address, return address, GC regs */ - stq $26, caml_last_return_address - lda $24, 0x200($sp) - stq $24, caml_bottom_of_stack - lda $24, 0x100($sp) - stq $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ -$113: stq $13, caml_young_ptr - /* Save trap pointer in case an exception is raised (e.g. sighandler) */ - stq $15, caml_exception_pointer - /* Save all integer regs used by the code generator in the context */ - stq $0, 0 * 8 ($24) - stq $1, 1 * 8 ($24) - stq $2, 2 * 8 ($24) - stq $3, 3 * 8 ($24) - stq $4, 4 * 8 ($24) - stq $5, 5 * 8 ($24) - stq $6, 6 * 8 ($24) - stq $7, 7 * 8 ($24) - stq $8, 8 * 8 ($24) - stq $9, 9 * 8 ($24) - stq $10, 10 * 8 ($24) - stq $11, 11 * 8 ($24) - stq $12, 12 * 8 ($24) - stq $16, 16 * 8 ($24) - stq $17, 17 * 8 ($24) - stq $18, 18 * 8 ($24) - stq $19, 19 * 8 ($24) - stq $20, 20 * 8 ($24) - stq $21, 21 * 8 ($24) - stq $22, 22 * 8 ($24) - /* Save all float regs that are not callee-save on the stack */ - stt $f0, 0 * 8 ($sp) - stt $f1, 1 * 8 ($sp) - stt $f10, 10 * 8 ($sp) - stt $f11, 11 * 8 ($sp) - stt $f12, 12 * 8 ($sp) - stt $f13, 13 * 8 ($sp) - stt $f14, 14 * 8 ($sp) - stt $f15, 15 * 8 ($sp) - stt $f16, 16 * 8 ($sp) - stt $f17, 17 * 8 ($sp) - stt $f18, 18 * 8 ($sp) - stt $f19, 19 * 8 ($sp) - stt $f20, 20 * 8 ($sp) - stt $f21, 21 * 8 ($sp) - stt $f22, 22 * 8 ($sp) - stt $f23, 23 * 8 ($sp) - stt $f24, 24 * 8 ($sp) - stt $f25, 25 * 8 ($sp) - stt $f26, 26 * 8 ($sp) - stt $f27, 27 * 8 ($sp) - stt $f29, 29 * 8 ($sp) - stt $f30, 30 * 8 ($sp) - /* Call the garbage collector */ - jsr caml_garbage_collection - ldgp $gp, 0($26) - /* Restore all regs used by the code generator */ - lda $24, 0x100($sp) - ldq $0, 0 * 8 ($24) - ldq $1, 1 * 8 ($24) - ldq $2, 2 * 8 ($24) - ldq $3, 3 * 8 ($24) - ldq $4, 4 * 8 ($24) - ldq $5, 5 * 8 ($24) - ldq $6, 6 * 8 ($24) - ldq $7, 7 * 8 ($24) - ldq $8, 8 * 8 ($24) - ldq $9, 9 * 8 ($24) - ldq $10, 10 * 8 ($24) - ldq $11, 11 * 8 ($24) - ldq $12, 12 * 8 ($24) - ldq $16, 16 * 8 ($24) - ldq $17, 17 * 8 ($24) - ldq $18, 18 * 8 ($24) - ldq $19, 19 * 8 ($24) - ldq $20, 20 * 8 ($24) - ldq $21, 21 * 8 ($24) - ldq $22, 22 * 8 ($24) - ldt $f0, 0 * 8 ($sp) - ldt $f1, 1 * 8 ($sp) - ldt $f10, 10 * 8 ($sp) - ldt $f11, 11 * 8 ($sp) - ldt $f12, 12 * 8 ($sp) - ldt $f13, 13 * 8 ($sp) - ldt $f14, 14 * 8 ($sp) - ldt $f15, 15 * 8 ($sp) - ldt $f16, 16 * 8 ($sp) - ldt $f17, 17 * 8 ($sp) - ldt $f18, 18 * 8 ($sp) - ldt $f19, 19 * 8 ($sp) - ldt $f20, 20 * 8 ($sp) - ldt $f21, 21 * 8 ($sp) - ldt $f22, 22 * 8 ($sp) - ldt $f23, 23 * 8 ($sp) - ldt $f24, 24 * 8 ($sp) - ldt $f25, 25 * 8 ($sp) - ldt $f26, 26 * 8 ($sp) - ldt $f27, 27 * 8 ($sp) - ldt $f29, 29 * 8 ($sp) - ldt $f30, 30 * 8 ($sp) - /* Reload new allocation pointer and allocation limit */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - /* Allocate space for the block */ - ldq $25, 0x1E8($sp) - subq $13, $25, $13 - cmpult $13, $14, $25 /* Check that we have enough free space */ - bne $25, $113 /* If not, call GC again */ - /* Say that we are back into Caml code */ - stq $31, caml_last_return_address - /* Return to caller */ - ldq $26, 0x1F8($sp) - ldq $gp, 0x1F0($sp) - lda $sp, 0x200($sp) - ret ($26) - - .end caml_call_gc - -/* Call a C function from Caml */ -/* Function to call is in $25 */ - - .globl caml_c_call - .ent caml_c_call - .align 3 -caml_c_call: - .prologue 0 - /* Preserve return address and caller's $gp in callee-save registers */ - mov $26, $9 - mov $gp, $10 - /* Rebuild $gp */ - br $27, $104 -$104: ldgp $gp, 0($27) - /* Record lowest stack address and return address */ - lda $11, caml_last_return_address - stq $26, 0($11) - stq $sp, caml_bottom_of_stack - /* Make the exception handler and alloc ptr available to the C code */ - lda $12, caml_young_ptr - stq $13, 0($12) - lda $14, caml_young_limit - stq $15, caml_exception_pointer - /* Call the function */ - mov $25, $27 - jsr ($25) - /* Reload alloc ptr and alloc limit */ - ldq $13, 0($12) /* $12 still points to caml_young_ptr */ - ldq $14, 0($14) /* $14 still points to caml_young_limit */ - /* Say that we are back into Caml code */ - stq $31, 0($11) /* $11 still points to caml_last_return_address */ - /* Restore $gp */ - mov $10, $gp - /* Return */ - ret ($9) - - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .ent caml_start_program - .align 3 -caml_start_program: - ldgp $gp, 0($27) - lda $25, caml_program - -/* Code shared with caml_callback* */ -$107: - /* Save return address */ - lda $sp, -128($sp) - stq $26, 0($sp) - /* Save all callee-save registers */ - stq $9, 8($sp) - stq $10, 16($sp) - stq $11, 24($sp) - stq $12, 32($sp) - stq $13, 40($sp) - stq $14, 48($sp) - stq $15, 56($sp) - stt $f2, 64($sp) - stt $f3, 72($sp) - stt $f4, 80($sp) - stt $f5, 88($sp) - stt $f6, 96($sp) - stt $f7, 104($sp) - stt $f8, 112($sp) - stt $f9, 120($sp) - /* Set up a callback link on the stack. */ - lda $sp, -32($sp) - ldq $0, caml_bottom_of_stack - stq $0, 0($sp) - ldq $1, caml_last_return_address - stq $1, 8($sp) - ldq $1, caml_gc_regs - stq $1, 16($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - lda $sp, -16($sp) - ldq $15, caml_exception_pointer - stq $15, 0($sp) - lda $0, $109 - stq $0, 8($sp) - mov $sp, $15 - /* Reload allocation pointers */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - /* We are back into Caml code */ - stq $31, caml_last_return_address - /* Call the Caml code */ - mov $25, $27 -$108: jsr ($25) - /* Reload $gp, masking off low bit in retaddr (might have been marked) */ - bic $26, 1, $26 - ldgp $gp, 4($26) - /* Pop the trap frame, restoring caml_exception_pointer */ - ldq $15, 0($sp) - stq $15, caml_exception_pointer - lda $sp, 16($sp) - /* Pop the callback link, restoring the global variables */ -$112: ldq $24, 0($sp) - stq $24, caml_bottom_of_stack - ldq $25, 8($sp) - stq $25, caml_last_return_address - ldq $24, 16($sp) - stq $24, caml_gc_regs - lda $sp, 32($sp) - /* Update allocation pointer */ - stq $13, caml_young_ptr - /* Reload callee-save registers */ - ldq $9, 8($sp) - ldq $10, 16($sp) - ldq $11, 24($sp) - ldq $12, 32($sp) - ldq $13, 40($sp) - ldq $14, 48($sp) - ldq $15, 56($sp) - ldt $f2, 64($sp) - ldt $f3, 72($sp) - ldt $f4, 80($sp) - ldt $f5, 88($sp) - ldt $f6, 96($sp) - ldt $f7, 104($sp) - ldt $f8, 112($sp) - ldt $f9, 120($sp) - /* Return to caller */ - ldq $26, 0($sp) - lda $sp, 128($sp) - ret ($26) - - /* The trap handler */ -$109: ldgp $gp, 0($26) - /* Save exception pointer */ - stq $15, caml_exception_pointer - /* Encode exception bucket as an exception result */ - or $0, 2, $0 - /* Return it */ - br $112 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl caml_raise_exception - .ent caml_raise_exception - .align 3 -caml_raise_exception: - ldgp $gp, 0($27) - mov $16, $0 /* Move exn bucket */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - stq $31, caml_last_return_address /* We're back into Caml */ - ldq $sp, caml_exception_pointer - ldq $15, 0($sp) - ldq $26, 8($sp) - lda $sp, 16($sp) - jmp $25, ($26) /* Keep retaddr in $25 to help debugging */ - .end caml_raise_exception - -/* Callback from C to Caml */ - - .globl caml_callback_exn - .ent caml_callback_exn - .align 3 -caml_callback_exn: - /* Initial shuffling of arguments */ - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $25, $17 /* environment */ - ldq $25, 0($25) /* code pointer */ - br $107 - .end caml_callback_exn - - .globl caml_callback2_exn - .ent caml_callback2_exn - .align 3 -caml_callback2_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $25, $18 /* environment */ - lda $25, caml_apply2 - br $107 - .end caml_callback2_exn - - .globl caml_callback3_exn - .ent caml_callback3_exn - .align 3 -caml_callback3_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $19, $18 /* third arg */ - mov $25, $19 /* environment */ - lda $25, caml_apply3 - br $107 - .end caml_callback3_exn - -/* Glue code to call [caml_array_bound_error] */ - - .globl caml_ml_array_bound_error - .ent caml_ml_array_bound_error - .align 3 -caml_ml_array_bound_error: - br $27, $111 -$111: ldgp $gp, 0($27) - lda $25, caml_array_bound_error - br caml_c_call /* never returns */ - .end caml_ml_array_bound_error - -#if defined(SYS_digital) - .rdata -#else - .section .rodata -#endif - .globl caml_system__frametable -caml_system__frametable: - .quad 1 /* one descriptor */ - .quad $108 + 4 /* return address into callback */ - .word -1 /* negative frame size => use callback link */ - .word 0 /* no roots here */ - .align 3 diff --git a/asmrun/hppa.S b/asmrun/hppa.S deleted file mode 100644 index 1f367e827..000000000 --- a/asmrun/hppa.S +++ /dev/null @@ -1,534 +0,0 @@ -;*********************************************************************** -;* * -;* OCaml * -;* * -;* 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 GNU Library General Public License, with * -;* the special exception on linking described in file ../LICENSE. * -;* * -;*********************************************************************** - -; $Id$ - -; Asm part of the runtime system for the HP PA-RISC processor. -; Must be preprocessed by cpp - -#ifdef SYS_hpux -#define G(x) x -#define CODESPACE .code -#define CODE_ALIGN 4 -#define EXPORT_CODE(x) .export x, entry, priv_lev=3 -#define EXPORT_DATA(x) .export x, data -#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry -#define ENDPROC .exit ! .procend -#define LOADHIGH(x) addil LR%x-$global$, %r27 -#define LOW(x) RR%x-$global$ -#define LOADHIGHLABEL(x) ldil LR%x, %r1 -#define LOWLABEL(x) RR%x -#endif - -#if defined(SYS_linux) || defined(SYS_gnu) -#define G(x) x -#define CODESPACE .text -#define CODE_ALIGN 8 -#define EXPORT_CODE(x) .globl x -#define EXPORT_DATA(x) .globl x -#define STARTPROC -#define ENDPROC -#define LOADHIGH(x) addil LR%x-$global$, %r27 -#define LOW(x) RR%x-$global$ -#define LOADHIGHLABEL(x) ldil LR%x, %r1 -#define LOWLABEL(x) RR%x -#endif - -#ifdef SYS_hpux - .space $PRIVATE$ - .subspa $DATA$,quad=1,align=8,access=31 - .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 - .space $TEXT$ - .subspa $LIT$,quad=0,align=8,access=44 - .subspa $CODE$,quad=0,align=8,access=44,code_only - .import $global$, data - .import $$dyncall, millicode - .import caml_garbage_collection, code - .import caml_program, code - .import caml_raise, code - .import caml_apply2, code - .import caml_apply3, code - .import caml_array_bound_error, code - -caml_young_limit .comm 8 -caml_young_ptr .comm 8 -caml_bottom_of_stack .comm 8 -caml_last_return_address .comm 8 -caml_gc_regs .comm 8 -caml_exception_pointer .comm 8 -caml_required_size .comm 8 -#endif - -#if defined(SYS_linux) || defined(SYS_gnu) - .align 8 - .comm G(young_limit), 4 - .comm G(young_ptr), 4 - .comm G(caml_bottom_of_stack), 4 - .comm G(caml_last_return_address), 4 - .comm G(caml_gc_regs), 4 - .comm G(caml_exception_pointer), 4 - .comm G(caml_required_size), 4 -#endif - -; Allocation functions - - CODESPACE - .align CODE_ALIGN - EXPORT_CODE(G(caml_allocN)) -G(caml_allocN): - STARTPROC -; Required size in %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<<,n %r3, %r1, G(caml_call_gc) ; nullify if taken (forward br.) - bv 0(%r2) - nop - ENDPROC - - EXPORT_CODE(G(caml_call_gc)) -G(caml_call_gc): - STARTPROC -; Save required size (%r29) - LOADHIGH(G(caml_required_size)) - stw %r29, LOW(G(caml_required_size))(%r1) -; Save current allocation pointer for debugging purposes - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler (if e.g. a sighandler raises) - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Reserve stack space -; 0x1C0 = 4 * 32 (int regs) + 8 * 32 (float regs) + 64 (for calling C) - ldo 0x1C0(%r30), %r30 -; Save caml_gc_regs -L100: ldo -(64 + 4*32)(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) -; Save all regs used by the code generator - copy %r31, %r1 - stws,ma %r6, 4(%r1) - stws,ma %r7, 4(%r1) - stws,ma %r8, 4(%r1) - stws,ma %r9, 4(%r1) - stws,ma %r10, 4(%r1) - stws,ma %r11, 4(%r1) - stws,ma %r12, 4(%r1) - stws,ma %r13, 4(%r1) - stws,ma %r14, 4(%r1) - stws,ma %r15, 4(%r1) - stws,ma %r16, 4(%r1) - stws,ma %r17, 4(%r1) - stws,ma %r18, 4(%r1) - stws,ma %r19, 4(%r1) - stws,ma %r20, 4(%r1) - stws,ma %r21, 4(%r1) - stws,ma %r22, 4(%r1) - stws,ma %r23, 4(%r1) - stws,ma %r24, 4(%r1) - stws,ma %r25, 4(%r1) - stws,ma %r26, 4(%r1) - stws,ma %r28, 4(%r1) - ldo -0x1C0(%r30), %r1 - fstds,ma %fr4, 8(%r1) - fstds,ma %fr5, 8(%r1) - fstds,ma %fr6, 8(%r1) - fstds,ma %fr7, 8(%r1) - fstds,ma %fr8, 8(%r1) - fstds,ma %fr9, 8(%r1) - fstds,ma %fr10, 8(%r1) - fstds,ma %fr11, 8(%r1) - fstds,ma %fr12, 8(%r1) - fstds,ma %fr13, 8(%r1) - fstds,ma %fr14, 8(%r1) - fstds,ma %fr15, 8(%r1) - fstds,ma %fr16, 8(%r1) - fstds,ma %fr17, 8(%r1) - fstds,ma %fr18, 8(%r1) - fstds,ma %fr19, 8(%r1) - fstds,ma %fr20, 8(%r1) - fstds,ma %fr21, 8(%r1) - fstds,ma %fr22, 8(%r1) - fstds,ma %fr23, 8(%r1) - fstds,ma %fr24, 8(%r1) - fstds,ma %fr25, 8(%r1) - fstds,ma %fr26, 8(%r1) - fstds,ma %fr27, 8(%r1) - fstds,ma %fr28, 8(%r1) - fstds,ma %fr29, 8(%r1) - fstds,ma %fr30, 8(%r1) - -; Call the garbage collector - bl G(caml_garbage_collection), %r2 - nop - -; Restore all regs used by the code generator - ldo -(64 + 4*32)(%r30), %r1 - ldws,ma 4(%r1), %r6 - ldws,ma 4(%r1), %r7 - ldws,ma 4(%r1), %r8 - ldws,ma 4(%r1), %r9 - ldws,ma 4(%r1), %r10 - ldws,ma 4(%r1), %r11 - ldws,ma 4(%r1), %r12 - ldws,ma 4(%r1), %r13 - ldws,ma 4(%r1), %r14 - ldws,ma 4(%r1), %r15 - ldws,ma 4(%r1), %r16 - ldws,ma 4(%r1), %r17 - ldws,ma 4(%r1), %r18 - ldws,ma 4(%r1), %r19 - ldws,ma 4(%r1), %r20 - ldws,ma 4(%r1), %r21 - ldws,ma 4(%r1), %r22 - ldws,ma 4(%r1), %r23 - ldws,ma 4(%r1), %r24 - ldws,ma 4(%r1), %r25 - ldws,ma 4(%r1), %r26 - ldws,ma 4(%r1), %r28 - ldo -0x1C0(%r30), %r1 - fldds,ma 8(%r1), %fr4 - fldds,ma 8(%r1), %fr5 - fldds,ma 8(%r1), %fr6 - fldds,ma 8(%r1), %fr7 - fldds,ma 8(%r1), %fr8 - fldds,ma 8(%r1), %fr9 - fldds,ma 8(%r1), %fr10 - fldds,ma 8(%r1), %fr11 - fldds,ma 8(%r1), %fr12 - fldds,ma 8(%r1), %fr13 - fldds,ma 8(%r1), %fr14 - fldds,ma 8(%r1), %fr15 - fldds,ma 8(%r1), %fr16 - fldds,ma 8(%r1), %fr17 - fldds,ma 8(%r1), %fr18 - fldds,ma 8(%r1), %fr19 - fldds,ma 8(%r1), %fr20 - fldds,ma 8(%r1), %fr21 - fldds,ma 8(%r1), %fr22 - fldds,ma 8(%r1), %fr23 - fldds,ma 8(%r1), %fr24 - fldds,ma 8(%r1), %fr25 - fldds,ma 8(%r1), %fr26 - fldds,ma 8(%r1), %fr27 - fldds,ma 8(%r1), %fr28 - fldds,ma 8(%r1), %fr29 - fldds,ma 8(%r1), %fr30 - -; Reload the allocation pointer - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 -; Allocate space for block - LOADHIGH(G(caml_required_size)) - ldw LOW(G(caml_required_size))(%r1), %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<< %r3, %r1, L100 - nop -; Return to caller - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 - bv 0(%r2) - ldo -0x1C0(%r30), %r30 - ENDPROC - -; Call a C function from Caml -; Function to call is in %r22 - - .align CODE_ALIGN -#ifdef SYS_hpux - .export G(caml_c_call), ENTRY, ARGW0=GR, ARGW1=GR, ARGW2=GR, ARGW3=GR -#else - EXPORT_CODE(G(caml_c_call)) -#endif -G(caml_c_call): - STARTPROC -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Save the allocation pointer - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Call the C function -#ifdef SYS_hpux - bl $$dyncall, %r31 -#else - ble 0(4, %r22) -#endif - copy %r31, %r2 ; in delay slot -; Reload return address - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 -; Reload allocation pointer - LOADHIGH(G(caml_young_ptr)) -; Return to caller - bv 0(%r2) - ldw LOW(G(caml_young_ptr))(%r1), %r3 ; in delay slot - ENDPROC - -; Start the Caml program - - .align CODE_ALIGN - EXPORT_CODE(G(caml_start_program)) -G(caml_start_program): - STARTPROC - LOADHIGH(G(caml_program)) - ldo LOW(G(caml_program))(%r1), %r22 - -; Code shared with caml_callback* -L102: -; Save return address - stw %r2,-20(%r30) - ldo 256(%r30), %r30 -; Save the callee-save registers - ldo -32(%r30), %r1 - stws,ma %r3, -4(%r1) - stws,ma %r4, -4(%r1) - stws,ma %r5, -4(%r1) - stws,ma %r6, -4(%r1) - stws,ma %r7, -4(%r1) - stws,ma %r8, -4(%r1) - stws,ma %r9, -4(%r1) - stws,ma %r10, -4(%r1) - stws,ma %r11, -4(%r1) - stws,ma %r12, -4(%r1) - stws,ma %r13, -4(%r1) - stws,ma %r14, -4(%r1) - stws,ma %r15, -4(%r1) - stws,ma %r16, -4(%r1) - stws,ma %r17, -4(%r1) - stws,ma %r18, -4(%r1) - fstds,ma %fr12, -8(%r1) - fstds,ma %fr13, -8(%r1) - fstds,ma %fr14, -8(%r1) - fstds,ma %fr15, -8(%r1) - fstds,ma %fr16, -8(%r1) - fstds,ma %fr17, -8(%r1) - fstds,ma %fr18, -8(%r1) - fstds,ma %fr19, -8(%r1) - fstds,ma %fr20, -8(%r1) - fstds,ma %fr21, -8(%r1) - fstds,ma %fr22, -8(%r1) - fstds,ma %fr23, -8(%r1) - fstds,ma %fr24, -8(%r1) - fstds,ma %fr25, -8(%r1) - fstds,ma %fr26, -8(%r1) - fstds,ma %fr27, -8(%r1) - fstds,ma %fr28, -8(%r1) - fstds,ma %fr29, -8(%r1) - fstds,ma %fr30, -8(%r1) - fstds,ma %fr31, -8(%r1) -; Set up a callback link - ldo 16(%r30), %r30 - LOADHIGH(G(caml_bottom_of_stack)) - ldw LOW(G(caml_bottom_of_stack))(%r1), %r1 - stw %r1, -16(%r30) - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r1 - stw %r1, -12(%r30) - LOADHIGH(G(caml_gc_regs)) - ldw LOW(G(caml_gc_regs))(%r1), %r1 - stw %r1, -8(%r30) -; Set up a trap frame to catch exceptions escaping the Caml code - ldo 8(%r30), %r30 - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r1 - stw %r1, -8(%r30) - LOADHIGHLABEL(L103) - ldo LOWLABEL(L103)(%r1), %r1 - stw %r1, -4(%r30) - copy %r30, %r5 -; Reload allocation pointers - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 - LOADHIGH(G(caml_young_limit)) - ldo LOW(G(caml_young_limit))(%r1), %r4 -; Call the Caml code - ble 0(4, %r22) - copy %r31, %r2 -L104: -; Pop the trap frame - ldw -8(%r30), %r31 - LOADHIGH(G(caml_exception_pointer)) - stw %r31, LOW(G(caml_exception_pointer))(%r1) - ldo -8(%r30), %r30 -; Pop the callback link -L105: - ldw -16(%r30), %r31 - LOADHIGH(G(caml_bottom_of_stack)) - stw %r31, LOW(G(caml_bottom_of_stack))(%r1) - ldw -12(%r30), %r31 - LOADHIGH(G(caml_last_return_address)) - stw %r31, LOW(G(caml_last_return_address))(%r1) - ldw -8(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) - ldo -16(%r30), %r30 -; Save allocation pointer - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Move result where C function expects it - copy %r26, %r28 -; Reload callee-save registers - ldo -32(%r30), %r1 - ldws,ma -4(%r1), %r3 - ldws,ma -4(%r1), %r4 - ldws,ma -4(%r1), %r5 - ldws,ma -4(%r1), %r6 - ldws,ma -4(%r1), %r7 - ldws,ma -4(%r1), %r8 - ldws,ma -4(%r1), %r9 - ldws,ma -4(%r1), %r10 - ldws,ma -4(%r1), %r11 - ldws,ma -4(%r1), %r12 - ldws,ma -4(%r1), %r13 - ldws,ma -4(%r1), %r14 - ldws,ma -4(%r1), %r15 - ldws,ma -4(%r1), %r16 - ldws,ma -4(%r1), %r17 - ldws,ma -4(%r1), %r18 - fldds,ma -8(%r1), %fr12 - fldds,ma -8(%r1), %fr13 - fldds,ma -8(%r1), %fr14 - fldds,ma -8(%r1), %fr15 - fldds,ma -8(%r1), %fr16 - fldds,ma -8(%r1), %fr17 - fldds,ma -8(%r1), %fr18 - fldds,ma -8(%r1), %fr19 - fldds,ma -8(%r1), %fr20 - fldds,ma -8(%r1), %fr21 - fldds,ma -8(%r1), %fr22 - fldds,ma -8(%r1), %fr23 - fldds,ma -8(%r1), %fr24 - fldds,ma -8(%r1), %fr25 - fldds,ma -8(%r1), %fr26 - fldds,ma -8(%r1), %fr27 - fldds,ma -8(%r1), %fr28 - fldds,ma -8(%r1), %fr29 - fldds,ma -8(%r1), %fr30 - fldds,ma -8(%r1), %fr31 -; Return to C - ldo -256(%r30), %r30 - ldw -20(%r30), %r2 - bv 0(%r2) - nop -; The trap handler -L103: -; Save exception pointer - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Encode exception bucket as an exception result and return it - ldi 2, %r1 - or %r26, %r1, %r26 -; Return it - b L105 - nop - -; Re-raise the exception through caml_raise, to clean up local C roots - ldo 64(%r30), %r30 - bl G(caml_raise), %r2 - nop - ENDPROC - -; Raise an exception from C - - .align CODE_ALIGN - EXPORT_CODE(G(caml_raise_exception)) -G(caml_raise_exception): - STARTPROC -; Cut the stack - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r30 -; Reload allocation registers - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 - LOADHIGH(G(caml_young_limit)) - ldo LOW(G(caml_young_limit))(%r1), %r4 -; Raise the exception - ldw -4(%r30), %r1 - ldw -8(%r30), %r5 - bv 0(%r1) - ldo -8(%r30), %r30 ; in delay slot - ENDPROC - -; Callbacks C -> ML - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback_exn)) -G(caml_callback_exn): - STARTPROC -; Initial shuffling of arguments - copy %r26, %r1 ; Closure - copy %r25, %r26 ; Argument - copy %r1, %r25 - b L102 - ldw 0(%r1), %r22 ; Code to call (in delay slot) - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback2_exn)) -G(caml_callback2_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r1, %r24 - LOADHIGH(G(caml_apply2)) - b L102 - ldo LOW(G(caml_apply2))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback3_exn)) -G(caml_callback3_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r23, %r24 ; Third argument - copy %r1, %r23 - LOADHIGH(G(caml_apply3)) - b L102 - ldo LOW(G(caml_apply3))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_ml_array_bound_error)) -G(caml_ml_array_bound_error): - STARTPROC -; Load address of [caml_array_bound_error] in %r22 - ldil LR%caml_array_bound_error, %r22 - ldo RR%caml_array_bound_error(%r22), %r22 -; Reserve 48 bytes of stack space and jump to caml_c_call - b G(caml_c_call) - ldo 48(%r30), %r30 /* in delay slot */ - ENDPROC - - .data - EXPORT_DATA(G(caml_system__frametable)) -G(caml_system__frametable): - .long 1 /* one descriptor */ - .long L104 + 3 /* return address into callback */ - .short -1 /* negative frame size => use callback link */ - .short 0 /* no roots */ diff --git a/asmrun/m68k.S b/asmrun/m68k.S deleted file mode 100644 index e456f3c35..000000000 --- a/asmrun/m68k.S +++ /dev/null @@ -1,244 +0,0 @@ -|*********************************************************************** -|* * -|* OCaml * -|* * -|* 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 GNU Library General Public License, with * -|* the special exception on linking described in file ../LICENSE. * -|* * -|*********************************************************************** - -| $Id$ - -| Asm part of the runtime system, Motorola 68k processor - - .comm _caml_requested_size, 4 - -| Allocation - - .text - .globl _caml_call_gc - .globl _caml_alloc1 - .globl _caml_alloc2 - .globl _caml_alloc3 - .globl _caml_allocN - -_caml_call_gc: - | Save desired size - movel d5, _caml_requested_size - | Record lowest stack address and return address - movel a7@, _caml_last_return_address - movel a7, d5 - addql #4, d5 - movel d5, _caml_bottom_of_stack - | Record current allocation pointer (for debugging) - movel d6, _caml_young_ptr - | Save all regs used by the code generator - movel d4, a7@- - movel d3, a7@- - movel d2, a7@- - movel d1, a7@- - movel d0, a7@- - movel a6, a7@- - movel a5, a7@- - movel a4, a7@- - movel a3, a7@- - movel a2, a7@- - movel a1, a7@- - movel a0, a7@- - movel a7, _caml_gc_regs - fmovem fp0-fp7, a7@- - | Call the garbage collector - jbsr _caml_garbage_collection - | Restore all regs used by the code generator - fmovem a7@+, fp0-fp7 - movel a7@+, a0 - movel a7@+, a1 - movel a7@+, a2 - movel a7@+, a3 - movel a7@+, a4 - movel a7@+, a5 - movel a7@+, a6 - movel a7@+, d0 - movel a7@+, d1 - movel a7@+, d2 - movel a7@+, d3 - movel a7@+, d4 - | Reload allocation pointer and allocate block - movel _caml_young_ptr, d6 - subl _caml_requested_size, d6 - | Return to caller - rts - -_caml_alloc1: - subql #8, d6 - cmpl _caml_young_limit, d6 - bcs L100 - rts -L100: moveq #8, d5 - bra _caml_call_gc - -_caml_alloc2: - subl #12, d6 - cmpl _caml_young_limit, d6 - bcs L101 - rts -L101: moveq #12, d5 - bra _caml_call_gc - -_caml_alloc3: - subl #16, d6 - cmpl _caml_young_limit, d6 - bcs L102 - rts -L102: moveq #16, d5 - bra _caml_call_gc - -_caml_allocN: - subl d5, d6 - cmpl _caml_young_limit, d6 - bcs _caml_call_gc - rts - -| Call a C function from Caml - - .globl _caml_c_call - -_caml_c_call: - | Record lowest stack address and return address - movel a7@+, _caml_last_return_address - movel a7, _caml_bottom_of_stack - | Save allocation pointer and exception pointer - movel d6, _caml_young_ptr - movel d7, _caml_exception_pointer - | Call the function (address in a0) - jbsr a0@ - | Reload allocation pointer - movel _caml_young_ptr, d6 - | Return to caller - movel _caml_last_return_address, a1 - jmp a1@ - -| Start the Caml program - - .globl _caml_start_program - -_caml_start_program: - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial code point is caml_program - lea _caml_program, a5 - -| Code shared between caml_start_program and caml_callback* - -L106: - | Build a callback link - movel _caml_gc_regs, a7@- - movel _caml_last_return_address, a7@- - movel _caml_bottom_of_stack, a7@- - | Build an exception handler - pea L108 - movel _caml_exception_pointer, a7@- - movel a7, d7 - | Load allocation pointer - movel _caml_young_ptr, d6 - | Call the Caml code - jbsr a5@ -L107: - | Move result where C code expects it - movel a0, d0 - | Save allocation pointer - movel d6, _caml_young_ptr - | Pop the exception handler - movel a7@+, _caml_exception_pointer - addql #4, a7 -L109: - | Pop the callback link, restoring the global variables - | used by caml_c_call - movel a7@+, _caml_bottom_of_stack - movel a7@+, _caml_last_return_address - movel a7@+, _caml_gc_regs - | Restore callee-save registers and return - fmovem a7@+, fp2-fp7 - moveml a7@+, a2-a6/d2-d7 - unlk a6 - rts -L108: - | Exception handler - | Save allocation pointer and exception pointer - movel d6, _caml_young_ptr - movel d7, _caml_exception_pointer - | Encode exception bucket as an exception result - movel a0, d0 - orl #2, d0 - | Return it - bra L109 - -| Raise an exception from C - - .globl _caml_raise_exception -_caml_raise_exception: - movel a7@(4), a0 | exception bucket - movel _caml_young_ptr, d6 - movel _caml_exception_pointer, a7 - movel a7@+, d7 - rts - -| Callback from C to Caml - - .globl _caml_callback_exn -_caml_callback_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a1 | closure - movel a6@(12), a0 | argument - movel a1@(0), a5 | code pointer - bra L106 - - .globl _caml_callback2_exn -_caml_callback2_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a2 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - lea _caml_apply2, a5 | code pointer - bra L106 - - .globl _caml_callback3_exn -_caml_callback3_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a3 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - movel a6@(20), a2 | third argument - lea _caml_apply3, a5 | code pointer - bra L106 - - .globl _caml_ml_array_bound_error -_caml_ml_array_bound_error: - | Load address of [caml_array_bound_error] in a0 and call it - lea _caml_array_bound_error, a0 - bra _caml_c_call - - .data - .globl _caml_system__frametable -_caml_system__frametable: - .long 1 | one descriptor - .long L107 | return address into callback - .word -1 | negative frame size => use callback link - .word 0 | no roots here diff --git a/asmrun/mips.s b/asmrun/mips.s deleted file mode 100644 index 5f63c3f3f..000000000 --- a/asmrun/mips.s +++ /dev/null @@ -1,386 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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 GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */ - -/* Allocation */ - - .text - - .globl caml_call_gc - .ent caml_call_gc - -caml_call_gc: - /* Reserve stack space for registers and saved $gp */ - /* 32 * 8 = 0x100 for float regs - 22 * 4 = 0x58 for integer regs - 8 = 0x8 for saved $gp ====> 0x160 total */ - subu $sp, $sp, 0x160 - /* Reinit $gp */ - .cpsetup $25, 0x158, caml_call_gc - /* Record return address */ - sw $31, caml_last_return_address - /* Record lowest stack address */ - addu $24, $sp, 0x160 - sw $24, caml_bottom_of_stack - /* Save pointer to register array */ - addu $24, $sp, 0x100 - sw $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ - sw $22, caml_young_ptr - /* Save the exception handler (if e.g. a sighandler raises) */ - sw $30, caml_exception_pointer - /* Save all regs used by the code generator on the stack */ - sw $2, 2 * 4($24) - sw $3, 3 * 4($24) - sw $4, 4 * 4($24) - sw $5, 5 * 4($24) - sw $6, 6 * 4($24) - sw $7, 7 * 4($24) - sw $8, 8 * 4($24) - sw $9, 9 * 4($24) - sw $10, 10 * 4($24) - sw $11, 11 * 4($24) - sw $12, 12 * 4($24) - sw $13, 13 * 4($24) - sw $14, 14 * 4($24) - sw $15, 15 * 4($24) - sw $16, 16 * 4($24) - sw $17, 17 * 4($24) - sw $18, 18 * 4($24) - sw $19, 19 * 4($24) - sw $20, 20 * 4($24) - sw $21, 21 * 4($24) - s.d $f0, 0 * 8($sp) - s.d $f1, 1 * 8($sp) - s.d $f2, 2 * 8($sp) - s.d $f3, 3 * 8($sp) - s.d $f4, 4 * 8($sp) - s.d $f5, 5 * 8($sp) - s.d $f6, 6 * 8($sp) - s.d $f7, 7 * 8($sp) - s.d $f8, 8 * 8($sp) - s.d $f9, 9 * 8($sp) - s.d $f10, 10 * 8($sp) - s.d $f11, 11 * 8($sp) - s.d $f12, 12 * 8($sp) - s.d $f13, 13 * 8($sp) - s.d $f14, 14 * 8($sp) - s.d $f15, 15 * 8($sp) - s.d $f16, 16 * 8($sp) - s.d $f17, 17 * 8($sp) - s.d $f18, 18 * 8($sp) - s.d $f19, 19 * 8($sp) - s.d $f20, 20 * 8($sp) - s.d $f21, 21 * 8($sp) - s.d $f22, 22 * 8($sp) - s.d $f23, 23 * 8($sp) - s.d $f24, 24 * 8($sp) - s.d $f25, 25 * 8($sp) - s.d $f26, 26 * 8($sp) - s.d $f27, 27 * 8($sp) - s.d $f28, 28 * 8($sp) - s.d $f29, 29 * 8($sp) - s.d $f30, 30 * 8($sp) - s.d $f31, 31 * 8($sp) - /* Call the garbage collector */ - jal caml_garbage_collection - /* Restore all regs used by the code generator */ - addu $24, $sp, 0x100 - lw $2, 2 * 4($24) - lw $3, 3 * 4($24) - lw $4, 4 * 4($24) - lw $5, 5 * 4($24) - lw $6, 6 * 4($24) - lw $7, 7 * 4($24) - lw $8, 8 * 4($24) - lw $9, 9 * 4($24) - lw $10, 10 * 4($24) - lw $11, 11 * 4($24) - lw $12, 12 * 4($24) - lw $13, 13 * 4($24) - lw $14, 14 * 4($24) - lw $15, 15 * 4($24) - lw $16, 16 * 4($24) - lw $17, 17 * 4($24) - lw $18, 18 * 4($24) - lw $19, 19 * 4($24) - lw $20, 20 * 4($24) - lw $21, 21 * 4($24) - l.d $f0, 0 * 8($sp) - l.d $f1, 1 * 8($sp) - l.d $f2, 2 * 8($sp) - l.d $f3, 3 * 8($sp) - l.d $f4, 4 * 8($sp) - l.d $f5, 5 * 8($sp) - l.d $f6, 6 * 8($sp) - l.d $f7, 7 * 8($sp) - l.d $f8, 8 * 8($sp) - l.d $f9, 9 * 8($sp) - l.d $f10, 10 * 8($sp) - l.d $f11, 11 * 8($sp) - l.d $f12, 12 * 8($sp) - l.d $f13, 13 * 8($sp) - l.d $f14, 14 * 8($sp) - l.d $f15, 15 * 8($sp) - l.d $f16, 16 * 8($sp) - l.d $f17, 17 * 8($sp) - l.d $f18, 18 * 8($sp) - l.d $f19, 19 * 8($sp) - l.d $f20, 20 * 8($sp) - l.d $f21, 21 * 8($sp) - l.d $f22, 22 * 8($sp) - l.d $f23, 23 * 8($sp) - l.d $f24, 24 * 8($sp) - l.d $f25, 25 * 8($sp) - l.d $f26, 26 * 8($sp) - l.d $f27, 27 * 8($sp) - l.d $f28, 28 * 8($sp) - l.d $f29, 29 * 8($sp) - l.d $f30, 30 * 8($sp) - l.d $f31, 31 * 8($sp) - /* Reload new allocation pointer and allocation limit */ - lw $22, caml_young_ptr - lw $23, caml_young_limit - /* Reload return address */ - lw $31, caml_last_return_address - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Adjust return address to restart the allocation sequence */ - subu $31, $31, 16 - /* Return */ - .cpreturn - addu $sp, $sp, 0x160 - j $31 - - .end caml_call_gc - -/* Call a C function from Caml */ - - .globl caml_c_call - .ent caml_c_call - -caml_c_call: - /* Function to call is in $24 */ - /* Set up $gp, saving caller's $gp in callee-save register $19 */ - .cpsetup $25, $19, caml_c_call - /* Preload addresses of interesting global variables - in callee-save registers */ - la $16, caml_last_return_address - la $17, caml_young_ptr - /* Save return address, bottom of stack, alloc ptr, exn ptr */ - sw $31, 0($16) /* caml_last_return_address */ - sw $sp, caml_bottom_of_stack - sw $22, 0($17) /* caml_young_ptr */ - sw $30, caml_exception_pointer - /* Call C function */ - move $25, $24 - jal $24 - /* Reload return address, alloc ptr, alloc limit */ - lw $31, 0($16) /* caml_last_return_address */ - lw $22, 0($17) /* caml_young_ptr */ - lw $23, caml_young_limit /* caml_young_limit */ - /* Zero caml_last_return_address, indicating we're back in Caml code */ - sw $0, 0($16) /* caml_last_return_address */ - /* Restore $gp and return */ - move $gp, $19 - j $31 - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .globl stray_exn_handler - .ent caml_start_program -caml_start_program: - /* Reserve space for callee-save registers */ - subu $sp, $sp, 0x90 - /* Setup $gp */ - .cpsetup $25, 0x80, caml_start_program - /* Load in $24 the code address to call */ - la $24, caml_program - /* Code shared with caml_callback* */ -$103: - /* Save return address */ - sd $31, 0x88($sp) - /* Save all callee-save registers */ - sd $16, 0x0($sp) - sd $17, 0x8($sp) - sd $18, 0x10($sp) - sd $19, 0x18($sp) - sd $20, 0x20($sp) - sd $21, 0x28($sp) - sd $22, 0x30($sp) - sd $23, 0x38($sp) - sd $30, 0x40($sp) - s.d $f20, 0x48($sp) - s.d $f22, 0x50($sp) - s.d $f24, 0x58($sp) - s.d $f26, 0x60($sp) - s.d $f28, 0x68($sp) - s.d $f30, 0x70($sp) - /* Set up a callback link on the stack. */ - subu $sp, $sp, 16 - lw $2, caml_bottom_of_stack - sw $2, 0($sp) - lw $3, caml_last_return_address - sw $3, 4($sp) - lw $4, caml_gc_regs - sw $4, 8($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - subu $sp, $sp, 16 - lw $30, caml_exception_pointer - sw $30, 0($sp) - la $2, $105 - sw $2, 4($sp) - sw $gp, 8($sp) - move $30, $sp - /* Reload allocation pointers */ - lw $22, caml_young_ptr - lw $23, caml_young_limit - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Call the Caml code */ - move $25, $24 - jal $24 -$104: - /* Pop the trap frame, restoring caml_exception_pointer */ - lw $24, 0($sp) - sw $24, caml_exception_pointer - addu $sp, $sp, 16 -$106: - /* Pop the callback link, restoring the global variables */ - lw $24, 0($sp) - sw $24, caml_bottom_of_stack - lw $25, 4($sp) - sw $25, caml_last_return_address - lw $24, 8($sp) - sw $24, caml_gc_regs - addu $sp, $sp, 16 - /* Update allocation pointer */ - sw $22, caml_young_ptr - /* Reload callee-save registers and return */ - ld $31, 0x88($sp) - ld $16, 0x0($sp) - ld $17, 0x8($sp) - ld $18, 0x10($sp) - ld $19, 0x18($sp) - ld $20, 0x20($sp) - ld $21, 0x28($sp) - ld $22, 0x30($sp) - ld $23, 0x38($sp) - ld $30, 0x40($sp) - l.d $f20, 0x48($sp) - l.d $f22, 0x50($sp) - l.d $f24, 0x58($sp) - l.d $f26, 0x60($sp) - l.d $f28, 0x68($sp) - l.d $f30, 0x70($sp) - .cpreturn - addu $sp, $sp, 0x90 - j $31 - - /* The trap handler: encode exception bucket as an exception result - and return it */ -$105: - sw $30, caml_exception_pointer - or $2, $2, 2 - b $106 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl caml_raise_exception - .ent caml_raise_exception -caml_raise_exception: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, caml_raise_exception - /* Branch to exn handler */ - move $2, $4 - lw $22, caml_young_ptr - lw $23, caml_young_limit - lw $sp, caml_exception_pointer - lw $30, 0($sp) - lw $24, 4($sp) - lw $gp, 8($sp) - addu $sp, $sp, 16 - j $24 - - .end caml_raise_exception - -/* Callback from C to Caml */ - - .globl caml_callback_exn - .ent caml_callback_exn -caml_callback_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback_exn - /* Initial shuffling of arguments */ - move $9, $4 /* closure */ - move $8, $5 /* argument */ - lw $24, 0($4) /* code pointer */ - b $103 - .end caml_callback_exn - - .globl caml_callback2_exn - .ent caml_callback2_exn -caml_callback2_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback2_exn - /* Initial shuffling of arguments */ - move $10, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - la $24, caml_apply2 /* code pointer */ - b $103 - - .end caml_callback2_exn - - .globl caml_callback3_exn - .ent caml_callback3_exn -caml_callback3_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback3_exn - /* Initial shuffling of arguments */ - move $11, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - move $10, $7 /* third argument */ - la $24, caml_apply3 /* code pointer */ - b $103 - - .end caml_callback3_exn - -/* Glue code to call [caml_array_bound_error] */ - - .globl caml_ml_array_bound_error - .ent caml_ml_array_bound_error - -caml_ml_array_bound_error: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, caml_ml_array_bound_error - la $24, caml_array_bound_error - jal caml_c_call /* never returns */ - - .end caml_ml_array_bound_error - - .rdata - .globl caml_system__frametable -caml_system__frametable: - .word 1 /* one descriptor */ - .word $104 /* return address into callback */ - .half -1 /* negative frame size => use callback link */ - .half 0 /* no roots here */ diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S deleted file mode 100644 index 21e1c7e28..000000000 --- a/asmrun/power-aix.S +++ /dev/null @@ -1,513 +0,0 @@ -#*********************************************************************** -#* * -#* OCaml * -#* * -#* 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 GNU Library General Public License, with * -#* the special exception on linking described in file ../LICENSE. * -#* * -#*********************************************************************** - -# $Id$ - - .csect .text[PR] - -#### Invoke the garbage collector. r0 contains the return address - - .globl .caml_call_gc -.caml_call_gc: - # Set up stack frame - stwu 1, -0x1C0(1) - # 0x1C0 = 4*32 (int regs) + 8*32 (float regs) + 64 (space for C call) - # Record last return address into Caml code - lwz 11, L..caml_last_return_address(2) - stw 0, 0(11) - # Record return address into call_gc stub code - mflr 0 - stw 0, 0x1C0+8(1) - # Record lowest stack address - lwz 11, L..caml_bottom_of_stack(2) - addi 0, 1, 0x1C0 - stw 0, 0(11) - # Record pointer to register array - lwz 11, L..caml_gc_regs(2) - addi 0, 1, 8*32 + 64 - stw 0, 0(11) - # Save current allocation pointer for debugging purposes - lwz 11, L..caml_young_ptr(2) - stw 31, 0(11) - # Save exception pointer (if e.g. a sighandler raises) - lwz 11, L..caml_exception_pointer(2) - stw 29, 0(11) - # Save all registers used by the code generator - addi 11, 1, 8*32 + 64 - 4 - stwu 3, 4(11) - stwu 4, 4(11) - stwu 5, 4(11) - stwu 6, 4(11) - stwu 7, 4(11) - stwu 8, 4(11) - stwu 9, 4(11) - stwu 10, 4(11) - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - addi 11, 1, 64 - 8 - stfdu 1, 8(11) - stfdu 2, 8(11) - stfdu 3, 8(11) - stfdu 4, 8(11) - stfdu 5, 8(11) - stfdu 6, 8(11) - stfdu 7, 8(11) - stfdu 8, 8(11) - stfdu 9, 8(11) - stfdu 10, 8(11) - stfdu 11, 8(11) - stfdu 12, 8(11) - stfdu 13, 8(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - # Call the GC - bl .caml_garbage_collection - or 0, 0, 0 - # Reload new allocation pointer and allocation limit - lwz 11, L..caml_young_ptr(2) - lwz 31, 0(11) - lwz 11, L..caml_young_limit(2) - lwz 30, 0(11) - # Restore all regs used by the code generator - addi 11, 1, 8*32 + 64 - 4 - lwzu 3, 4(11) - lwzu 4, 4(11) - lwzu 5, 4(11) - lwzu 6, 4(11) - lwzu 7, 4(11) - lwzu 8, 4(11) - lwzu 9, 4(11) - lwzu 10, 4(11) - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - addi 11, 1, 64 - 8 - lfdu 1, 8(11) - lfdu 2, 8(11) - lfdu 3, 8(11) - lfdu 4, 8(11) - lfdu 5, 8(11) - lfdu 6, 8(11) - lfdu 7, 8(11) - lfdu 8, 8(11) - lfdu 9, 8(11) - lfdu 10, 8(11) - lfdu 11, 8(11) - lfdu 12, 8(11) - lfdu 13, 8(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - # Return to caller (the stub code), leaving return address into - # Caml code in the link register - lwz 0, 0x1C0+8(1) - mtctr 0 - lwz 11, L..caml_last_return_address(2) - lwz 0, 0(11) - addic 0, 0, -16 # Restart the allocation (4 instructions) - mtlr 0 - # Say we are back into Caml code - li 12, 0 - stw 12, 0(11) # 11 still points to caml_last_return_address - # Deallocate stack frame - addi 1, 1, 0x1C0 - # Return - bctr - -#### Call a C function from Caml - - .globl .caml_c_call -.caml_c_call: - # Save return address in 25 - mflr 25 - # Record lowest stack address and return address - lwz 27, L..caml_bottom_of_stack(2) - lwz 24, L..caml_last_return_address(2) - stw 1, 0(27) - stw 25, 0(24) - # Make the exception handler and alloc ptr available to the C code - lwz 27, L..caml_young_ptr(2) - lwz 26, L..caml_exception_pointer(2) - stw 31, 0(27) - stw 29, 0(26) - # Preserve RTOC and return address in callee-save registers - # The C function will preserve them, and the Caml code does not - # expect them to be preserved - # Return address is in 25, RTOC is in 26, pointer to caml_young_ptr in 27, - # pointer to caml_last_return_address is in 24 - # Call the function (descriptor in 11) - lwz 0, 0(11) - mr 26, 2 - mtlr 0 - lwz 2, 4(11) - lwz 11, 8(11) - blrl - # Restore return address - mtlr 25 - # Restore RTOC - mr 2, 26 - # Reload allocation pointer - lwz 31, 0(27) # 27 still points to caml_young_ptr - # Say we are back into Caml code - li 12, 0 - stw 12, 0(24) # 24 still points to caml_last_return_address - # Return to caller - blr - -#### Raise an exception from C - - .globl .caml_raise_exception -.caml_raise_exception: - # Reload Caml global registers - lwz 4, L..caml_exception_pointer(2) - lwz 5, L..caml_young_ptr(2) - lwz 6, L..caml_young_limit(2) - lwz 1, 0(4) - lwz 31, 0(5) - lwz 30, 0(6) - # Say we are back into Caml code - lwz 4, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(4) - # Pop trap frame - lwz 0, 0(1) - lwz 29, 4(1) - mtlr 0 - lwz 2, 20(1) - addi 1, 1, 32 - # Branch to handler - blr - -#### Start the Caml program - - .globl .caml_start_program -.caml_start_program: - lwz 11, L..caml_program(2) - -#### Code shared between caml_start_program and caml_callback* - -L..102: - mflr 0 - # Save return address - stw 0, 8(1) - # Save all callee-save registers - stw 13, -76(1) - stw 14, -72(1) - stw 15, -68(1) - stw 16, -64(1) - stw 17, -60(1) - stw 18, -56(1) - stw 19, -52(1) - stw 20, -48(1) - stw 21, -44(1) - stw 22, -40(1) - stw 23, -36(1) - stw 24, -32(1) - stw 25, -28(1) - stw 26, -24(1) - stw 27, -20(1) - stw 28, -16(1) - stw 29, -12(1) - stw 30, -8(1) - stw 31, -4(1) - stfd 14, -224(1) - stfd 15, -216(1) - stfd 16, -208(1) - stfd 17, -200(1) - stfd 18, -192(1) - stfd 19, -184(1) - stfd 20, -176(1) - stfd 21, -168(1) - stfd 22, -160(1) - stfd 23, -152(1) - stfd 24, -144(1) - stfd 25, -136(1) - stfd 26, -128(1) - stfd 27, -120(1) - stfd 28, -112(1) - stfd 29, -104(1) - stfd 30, -96(1) - stfd 31, -88(1) - # Allocate and link stack frame - stwu 1, -288(1) - # Set up a callback link - addi 1, 1, -32 - lwz 9, L..caml_bottom_of_stack(2) - lwz 10, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - lwz 9, 0(9) - lwz 10, 0(10) - lwz 12, 0(12) - stw 9, 0(1) - stw 10, 4(1) - stw 12, 8(1) - # Build an exception handler to catch exceptions escaping out of Caml - bl L..103 - b L..104 -L..103: - addi 1, 1, -32 - lwz 9, L..caml_exception_pointer(2) - mflr 0 - lwz 29, 0(9) - stw 0, 0(1) - stw 29, 4(1) - stw 2, 20(1) - mr 29, 1 - # Reload allocation pointers - lwz 9, L..caml_young_ptr(2) - lwz 10, L..caml_young_limit(2) - lwz 31, 0(9) - lwz 30, 0(10) - # Say we are back into Caml code - lwz 9, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(9) - # Call the Caml code - lwz 0, 0(11) - stw 2, 20(1) - mtlr 0 - lwz 2, 4(11) -L..105: - blrl - lwz 2, 20(1) - # Pop the trap frame, restoring caml_exception_pointer - lwz 9, 4(1) - lwz 10, L..caml_exception_pointer(2) - addi 1, 1, 32 - stw 9, 0(10) - # Pop the callback link, restoring the global variables -L..106: - lwz 7, 0(1) - lwz 8, 4(1) - lwz 9, 8(1) - lwz 10, L..caml_bottom_of_stack(2) - lwz 11, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - stw 7, 0(10) - stw 8, 0(11) - stw 9, 0(12) - addi 1, 1, 32 - # Update allocation pointer - lwz 11, L..caml_young_ptr(2) - stw 31, 0(11) - # Deallocate stack frame - addi 1, 1, 288 - # Restore callee-save registers - lwz 13, -76(1) - lwz 14, -72(1) - lwz 15, -68(1) - lwz 16, -64(1) - lwz 17, -60(1) - lwz 18, -56(1) - lwz 19, -52(1) - lwz 20, -48(1) - lwz 21, -44(1) - lwz 22, -40(1) - lwz 23, -36(1) - lwz 24, -32(1) - lwz 25, -28(1) - lwz 26, -24(1) - lwz 27, -20(1) - lwz 28, -16(1) - lwz 29, -12(1) - lwz 30, -8(1) - lwz 31, -4(1) - lfd 14, -224(1) - lfd 15, -216(1) - lfd 16, -208(1) - lfd 17, -200(1) - lfd 18, -192(1) - lfd 19, -184(1) - lfd 20, -176(1) - lfd 21, -168(1) - lfd 22, -160(1) - lfd 23, -152(1) - lfd 24, -144(1) - lfd 25, -136(1) - lfd 26, -128(1) - lfd 27, -120(1) - lfd 28, -112(1) - lfd 29, -104(1) - lfd 30, -96(1) - lfd 31, -88(1) - # Reload return address - lwz 0, 8(1) - mtlr 0 - # Return - blr - # The trap handler: -L..104: - # Update caml_exception_pointer - lwz 9, L..caml_exception_pointer(2) - stw 29, 0(9) - # Encode exception bucket as an exception result and return it - ori 3, 3, 2 - b L..106 - -#### Callback from C to Caml - - .globl .caml_callback_exn -.caml_callback_exn: - # Initial shuffling of arguments - mr 0, 3 # Closure - mr 3, 4 # Argument - mr 4, 0 - lwz 11, 0(4) # Code pointer - b L..102 - - .globl .caml_callback2_exn -.caml_callback2_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 0 - lwz 11, L..caml_apply2(2) - b L..102 - - .globl .caml_callback3_exn -.caml_callback3_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 6 # Third argument - mr 6, 0 - lwz 11, L..caml_apply3(2) - b L..102 - -#### Frame table - - .csect .data[RW] - .globl caml_system__frametable -caml_system__frametable: - .long 1 # one descriptor - .long L..105 + 4 # return address into callback - .short -1 # negative size count => use callback link - .short 0 # no roots here - -#### TOC entries - - .toc -L..caml_young_limit: - .tc caml_young_limit[TC], caml_young_limit -L..caml_young_ptr: - .tc caml_young_ptr[TC], caml_young_ptr -L..caml_bottom_of_stack: - .tc caml_bottom_of_stack[TC], caml_bottom_of_stack -L..caml_last_return_address: - .tc caml_last_return_address[TC], caml_last_return_address -L..caml_gc_regs: - .tc caml_gc_regs[TC], caml_gc_regs -L..caml_exception_pointer: - .tc caml_exception_pointer[TC], caml_exception_pointer -L..gc_entry_regs: - .tc gc_entry_regs[TC], gc_entry_regs -L..gc_entry_float_regs: - .tc gc_entry_float_regs[TC], gc_entry_float_regs -L..caml_program: - .tc caml_program[TC], caml_program -L..caml_apply2: - .tc caml_apply2[TC], caml_apply2 -L..caml_apply3: - .tc caml_apply3[TC], caml_apply3 - -#### Function closures - - .csect caml_call_gc[DS] -caml_call_gc: - .long .caml_call_gc, TOC[tc0], 0 - - .globl caml_c_call - .csect caml_c_call[DS] -caml_c_call: - .long .caml_c_call, TOC[tc0], 0 - - .globl caml_raise_exception - .csect caml_raise_exception[DS] -caml_raise_exception: - .long .caml_raise_exception, TOC[tc0], 0 - - .globl caml_start_program - .csect caml_start_program[DS] -caml_start_program: - .long .caml_start_program, TOC[tc0], 0 - - .globl caml_callback_exn - .csect caml_callback_exn[DS] -caml_callback_exn: - .long .caml_callback_exn, TOC[tc0], 0 - - .globl caml_callback2_exn - .csect caml_callback2_exn[DS] -caml_callback2_exn: - .long .caml_callback2_exn, TOC[tc0], 0 - - .globl caml_callback3_exn - .csect caml_callback3_exn[DS] -caml_callback3_exn: - .long .caml_callback3_exn, TOC[tc0], 0 diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c deleted file mode 100644 index b888df4c0..000000000 --- a/otherlibs/num/bng_alpha.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the Alpha architecture. */ - -#define BngMult(resh,resl,arg1,arg2) \ - asm("mulq %2, %3, %0 \n\t" \ - "umulh %2, %3, %1" \ - : "=&r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c deleted file mode 100644 index 92ec2c03e..000000000 --- a/otherlibs/num/bng_mips.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the MIPS architecture. */ - -#define BngMult(resh,resl,arg1,arg2) \ - asm("multu %2, %3 \n\t" \ - "mflo %0 \n\t" \ - "mfhi %1" \ - : "=r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) |