Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. 

So long and thanks for all the fish.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11882 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2011-12-17 11:12:50 +00:00
parent 9178181eae
commit 3e42214295
34 changed files with 11 additions and 7863 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Changes
View File

@ -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
README
View File

@ -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,

83
asmcomp/alpha/arch.ml
View File

@ -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

861
asmcomp/alpha/emit.mlp
View File

@ -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 := []

217
asmcomp/alpha/proc.ml
View File

@ -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;;

18
asmcomp/alpha/reload.ml
View File

@ -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

70
asmcomp/alpha/scheduling.ml
View File

@ -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

83
asmcomp/alpha/selection.ml
View File

@ -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

73
asmcomp/hppa/arch.ml
View File

@ -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)

1042
asmcomp/hppa/emit.mlp
View File

File diff suppressed because it is too large Load Diff

224
asmcomp/hppa/proc.ml
View File

@ -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;;

38
asmcomp/hppa/reload.ml
View File

@ -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

59
asmcomp/hppa/scheduling.ml
View File

@ -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

109
asmcomp/hppa/selection.ml
View File

@ -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

88
asmcomp/ia64/arch.ml
View File

@ -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"

1327
asmcomp/ia64/emit.mlp
View File

File diff suppressed because it is too large Load Diff

217
asmcomp/ia64/proc.ml
View File

@ -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;;

18
asmcomp/ia64/reload.ml
View File

@ -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

20
asmcomp/ia64/scheduling.ml
View File

@ -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

178
asmcomp/ia64/selection.ml
View File

@ -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

8
asmcomp/m68k/README
View File

@ -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.

71
asmcomp/mips/arch.ml
View File

@ -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"

593
asmcomp/mips/emit.mlp
View File

@ -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 := []

210
asmcomp/mips/proc.ml
View File

@ -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;;

18
asmcomp/mips/reload.ml
View File

@ -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

20
asmcomp/mips/scheduling.ml
View File

@ -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

43
asmcomp/mips/selection.ml
View File

@ -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

440
asmrun/alpha.S
View File

@ -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

534
asmrun/hppa.S
View File

@ -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 */

244
asmrun/m68k.S
View File

@ -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

386
asmrun/mips.s
View File

@ -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 */

513
asmrun/power-aix.S
View File

@ -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

22
otherlibs/num/bng_alpha.c
View File

@ -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))

23
otherlibs/num/bng_mips.c
View File

@ -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))