rpms/ocaml
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
bf330de0a3
ocaml/0006-Add-RISC-V-backend-runtime.patch
Richard W.M. Jones 725d4a96c7 Revert "New upstream version 4.05.0." 
It's been decided to allow the Fedora 27 Mass Rebuild to take place
before OCaml 4.05.0 is added to Fedora.  To avoid this package
accidentally getting included in the mass rebuild, this commit reverts
the new upstream version, and then it will be un-re-verted after the
Mass Rebuild.

This reverts commit 40c060b8ec.
2017-07-21 11:00:11 +01:00

1718 lines
58 KiB
Diff
Raw Blame History

From c7d7b98e82b5571965e57c1537899094222f3157 Mon Sep 17 00:00:00 2001
From: Nicolas Ojeda Bar <n.oje.bar@gmail.com>
Date: Fri, 4 Nov 2016 20:39:09 +0100
Subject: [PATCH 6/9] Add RISC-V backend & runtime
---
README.adoc | 1 +
asmcomp/riscv/CSE.ml | 36 +++
asmcomp/riscv/arch.ml | 84 ++++++
asmcomp/riscv/emit.mlp | 616 ++++++++++++++++++++++++++++++++++++++++++++
asmcomp/riscv/proc.ml | 301 ++++++++++++++++++++++
asmcomp/riscv/reload.ml | 16 ++
asmcomp/riscv/scheduling.ml | 19 ++
asmcomp/riscv/selection.ml | 85 ++++++
asmrun/riscv.S | 424 ++++++++++++++++++++++++++++++
byterun/caml/stack.h | 5 +
configure | 5 +-
11 files changed, 1591 insertions(+), 1 deletion(-)
create mode 100644 asmcomp/riscv/CSE.ml
create mode 100644 asmcomp/riscv/arch.ml
create mode 100644 asmcomp/riscv/emit.mlp
create mode 100644 asmcomp/riscv/proc.ml
create mode 100644 asmcomp/riscv/reload.ml
create mode 100644 asmcomp/riscv/scheduling.ml
create mode 100644 asmcomp/riscv/selection.ml
create mode 100644 asmrun/riscv.S
diff --git a/README.adoc b/README.adoc
index 480b0250f..cb6eebf1d 100644
--- a/README.adoc
+++ b/README.adoc
@@ -34,6 +34,7 @@ IA32 (Pentium):: NetBSD, OpenBSD, Solaris 9
PowerPC:: NetBSD
ARM:: NetBSD
SPARC:: Solaris, Linux, NetBSD
+RISC-V:: Linux
Other operating systems for the processors above have not been tested, but
the compiler may work under other operating systems with little work.
diff --git a/asmcomp/riscv/CSE.ml b/asmcomp/riscv/CSE.ml
new file mode 100644
index 000000000..302811a99
--- /dev/null
+++ b/asmcomp/riscv/CSE.ml
@@ -0,0 +1,36 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2106 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. *)
+(* *)
+(***********************************************************************)
+
+(* CSE for the RISC-V *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object (_self)
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+ match op with
+ | Ispecific(Imultaddf _ | Imultsubf _) -> Op_pure
+ | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+ match op with
+ | Iconst_int n -> n <= 0x7FFn && n >= -0x800n
+ | _ -> false
+
+end
+
+let fundecl f =
+ (new cse)#fundecl f
diff --git a/asmcomp/riscv/arch.ml b/asmcomp/riscv/arch.ml
new file mode 100644
index 000000000..61a38b1dd
--- /dev/null
+++ b/asmcomp/riscv/arch.ml
@@ -0,0 +1,84 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Specific operations for the RISC-V processor *)
+
+open Format
+
+(* Machine-specific command-line options *)
+
+let command_line_options = []
+
+(* Specific operations *)
+
+type specific_operation =
+ | Imultaddf of bool (* multiply, optionally negate, and add *)
+ | Imultsubf of bool (* multiply, optionally negate, and subtract *)
+
+let spacetime_node_hole_pointer_is_live_before = function
+ | Imultaddf _ | Imultsubf _ -> false
+
+(* Addressing modes *)
+
+type addressing_mode =
+ | Iindexed of int (* reg + displ *)
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let rv64 =
+ match Config.model with "riscv64" -> true | "riscv32" -> false | _ -> assert false
+
+let size_addr = if rv64 then 8 else 4
+let size_int = size_addr
+let size_float = 8
+
+let allow_unaligned_access = false
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+ match addr with
+ | Iindexed n -> Iindexed(n + delta)
+
+let num_args_addressing = function
+ | Iindexed _ -> 1
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+ match addr with
+ | 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
+ | Imultaddf false ->
+ fprintf ppf "%a *f %a +f %a"
+ printreg arg.(0) printreg arg.(1) printreg arg.(2)
+ | Imultaddf true ->
+ fprintf ppf "-f (%a *f %a +f %a)"
+ printreg arg.(0) printreg arg.(1) printreg arg.(2)
+ | Imultsubf false ->
+ fprintf ppf "%a *f %a -f %a"
+ printreg arg.(0) printreg arg.(1) printreg arg.(2)
+ | Imultsubf true ->
+ fprintf ppf "-f (%a *f %a -f %a)"
+ printreg arg.(0) printreg arg.(1) printreg arg.(2)
diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp
new file mode 100644
index 000000000..6d0e3aefd
--- /dev/null
+++ b/asmcomp/riscv/emit.mlp
@@ -0,0 +1,616 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Emission of RISC-V assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Layout of the stack. The stack is kept 16-aligned. *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+ let size =
+ !stack_offset + (* Trap frame, outgoing parameters *)
+ size_int * num_stack_slots.(0) + (* Local int variables *)
+ size_float * num_stack_slots.(1) + (* Local float variables *)
+ (if !contains_calls then size_addr else 0) in (* The return address *)
+ Misc.align size 16
+
+let slot_offset loc cls =
+ match loc with
+ | Local n ->
+ if cls = 0
+ then !stack_offset + num_stack_slots.(1) * size_float + n * size_int
+ else !stack_offset + n * size_float
+ | Incoming n -> frame_size() + n
+ | Outgoing n -> n
+
+(* Output a symbol *)
+
+let emit_symbol s =
+ Emitaux.emit_symbol '.' s
+
+(* Output a label *)
+
+let label_prefix = "L"
+
+let emit_label lbl =
+ emit_string label_prefix; emit_int lbl
+
+(* Section switching *)
+
+let data_space =
+ ".section .data"
+
+let code_space =
+ ".section .text"
+
+let rodata_space =
+ ".section .rodata"
+
+let reg_tmp1 = phys_reg 21 (* used by the assembler *)
+let reg_tmp2 = phys_reg 22
+let reg_t2 = phys_reg 16
+(* let reg_fp = phys_reg 23 *)
+let reg_trap = phys_reg 24
+let reg_alloc_ptr = phys_reg 25
+let reg_alloc_lim = phys_reg 26
+
+(* Names of instructions that differ in 32 and 64-bit modes *)
+
+let lg = if rv64 then "ld" else "lw"
+let stg = if rv64 then "sd" else "sw"
+let datag = if rv64 then ".quad" else ".long"
+
+(* Output a pseudo-register *)
+
+let emit_reg = function
+ | {loc = Reg r} -> emit_string (register_name r)
+ | _ -> fatal_error "Emit.emit_reg"
+
+(* 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.emit_stack"
+
+(* Record live pointers at call points *)
+
+let record_frame_label ?label live raise_ dbg =
+ let lbl =
+ match label with
+ | None -> new_label()
+ | Some label -> label
+ in
+ let live_offset = ref [] in
+ Reg.Set.iter
+ (function
+ {typ = Val; loc = Reg r} ->
+ live_offset := (r lsl 1) + 1 :: !live_offset
+ | {typ = Val; loc = Stack s} as reg ->
+ live_offset := slot_offset s (register_class reg) :: !live_offset
+ | {typ = Addr} as r ->
+ Misc.fatal_error ("bad GC root " ^ Reg.name r)
+ | _ -> ()
+ )
+ live;
+ frame_descriptors :=
+ { fd_lbl = lbl;
+ fd_frame_size = frame_size();
+ fd_live_offset = !live_offset;
+ fd_raise = raise_;
+ fd_debuginfo = dbg } :: !frame_descriptors;
+ lbl
+
+let record_frame ?label live raise_ dbg =
+ let lbl = record_frame_label ?label live raise_ dbg in
+ `{emit_label lbl}:\n`
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+ { gc_lbl: label; (* Entry label *)
+ gc_return_lbl: label; (* Where to branch after GC *)
+ gc_frame_lbl: label } (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+ `{emit_label gc.gc_lbl}:\n`;
+ ` call {emit_symbol "caml_call_gc"}\n`;
+ `{emit_label gc.gc_frame_lbl}:\n`;
+ ` j {emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_ml_array_bound_error.
+ In debug mode, we maintain one call to caml_ml_array_bound_error
+ per bound check site. Otherwise, we can share a single call. *)
+
+type bound_error_call =
+ { bd_lbl: label; (* Entry label *)
+ bd_frame_lbl: label } (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+
+let bound_error_label ?label dbg =
+ if !Clflags.debug || !bound_error_sites = [] then begin
+ let lbl_bound_error = new_label() in
+ let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+ bound_error_sites :=
+ { bd_lbl = lbl_bound_error;
+ bd_frame_lbl = lbl_frame } :: !bound_error_sites;
+ lbl_bound_error
+ end else
+ let bd = List.hd !bound_error_sites in
+ bd.bd_lbl
+
+let emit_call_bound_error bd =
+ `{emit_label bd.bd_lbl}:\n`;
+ ` call {emit_symbol "caml_ml_array_bound_error"}\n`;
+ `{emit_label bd.bd_frame_lbl}:\n`
+
+(* Record floating-point literals *)
+
+let float_literals = ref ([] : (int64 * int) list)
+
+(* Names for various instructions *)
+
+let name_for_intop = function
+ | Iadd -> "add"
+ | Isub -> "sub"
+ | Imul -> "mul"
+ | Imulh -> "mulh"
+ | Idiv -> "div"
+ | Iand -> "and"
+ | Ior -> "or"
+ | Ixor -> "xor"
+ | Ilsl -> "sll"
+ | Ilsr -> "srl"
+ | Iasr -> "sra"
+ | Imod -> "rem"
+ | _ -> fatal_error "Emit.Intop"
+
+let name_for_intop_imm = function
+ | Iadd -> "addi"
+ | Iand -> "andi"
+ | Ior -> "ori"
+ | Ixor -> "xori"
+ | Ilsl -> "slli"
+ | Ilsr -> "srli"
+ | Iasr -> "srai"
+ | _ -> fatal_error "Emit.Intop_imm"
+
+let name_for_floatop1 = function
+ | Inegf -> "fneg.d"
+ | Iabsf -> "fabs.d"
+ | _ -> fatal_error "Emit.Iopf1"
+
+let name_for_floatop2 = function
+ | Iaddf -> "fadd.d"
+ | Isubf -> "fsub.d"
+ | Imulf -> "fmul.d"
+ | Idivf -> "fdiv.d"
+ | _ -> fatal_error "Emit.Iopf2"
+
+let name_for_specific = function
+ | Imultaddf false -> "fmadd.d"
+ | Imultaddf true -> "fnmadd.d"
+ | Imultsubf false -> "fmsub.d"
+ | Imultsubf true -> "fnmsub.d"
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+
+(* Output the assembly code for an instruction *)
+
+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 _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
+ ` mv {emit_reg dst}, {emit_reg src}\n`
+ | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
+ ` fmv.d {emit_reg dst}, {emit_reg src}\n`
+ | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
+ ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n`
+ | {loc = Reg _; typ = Float}, {loc = Stack _} ->
+ ` fsd {emit_reg src}, {emit_stack dst}\n`
+ | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _ } ->
+ ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n`
+ | {loc = Stack _; typ = Float}, {loc = Reg _} ->
+ ` fld {emit_reg dst}, {emit_stack src}\n`
+ | _ ->
+ fatal_error "Emit: Imove"
+ end
+ | Lop(Iconst_int n) ->
+ ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n`
+ | Lop(Iconst_float f) ->
+ let lbl = new_label() in
+ float_literals := (f, lbl) :: !float_literals;
+ ` fld {emit_reg i.res.(0)}, {emit_label lbl}, {emit_reg reg_tmp1}\n`
+ | Lop(Iconst_symbol s) ->
+ ` la {emit_reg i.res.(0)}, {emit_symbol s}\n`
+ | Lop(Icall_ind {label_after = label}) ->
+ ` jalr {emit_reg i.arg.(0)}\n`;
+ record_frame ~label i.live false i.dbg
+ | Lop(Icall_imm {func; label_after = label}) ->
+ ` call {emit_symbol func}\n`;
+ record_frame ~label i.live false i.dbg
+ | Lop(Itailcall_ind {label_after = _}) ->
+ let n = frame_size() in
+ if !contains_calls then
+ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`;
+ if n > 0 then
+ ` addi sp, sp, {emit_int n}\n`;
+ ` jr {emit_reg i.arg.(0)}\n`
+ | Lop(Itailcall_imm {func; label_after = _}) ->
+ if func = !function_name then begin
+ ` j {emit_label !tailrec_entry_point}\n`
+ end else begin
+ let n = frame_size() in
+ if !contains_calls then
+ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`;
+ if n > 0 then
+ ` addi sp, sp, {emit_int n}\n`;
+ ` tail {emit_symbol func}\n`
+ end
+ | Lop(Iextcall{func; alloc = true; label_after = label}) ->
+ ` la {emit_reg reg_t2}, {emit_symbol func}\n`;
+ ` call {emit_symbol "caml_c_call"}\n`;
+ record_frame ~label i.live false i.dbg
+ | Lop(Iextcall{func; alloc = false; label_after = _}) ->
+ ` call {emit_symbol func}\n`
+ | Lop(Istackoffset n) ->
+ assert (n mod 16 = 0);
+ ` addi sp, sp, {emit_int (-n)}\n`;
+ stack_offset := !stack_offset + n
+ | Lop(Iload(Single, Iindexed ofs)) ->
+ ` flw {emit_reg i.res.(0)}, {emit_int ofs}({emit_reg i.arg.(0)})\n`;
+ ` fcvt.d.s {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | Lop(Iload(chunk, Iindexed ofs)) ->
+ let instr =
+ match chunk with
+ | Byte_unsigned -> "lbu"
+ | Byte_signed -> "lb"
+ | Sixteen_unsigned -> "lhu"
+ | Sixteen_signed -> "lh"
+ | Thirtytwo_unsigned -> if rv64 then "lwu" else "lw"
+ | Thirtytwo_signed -> "lw"
+ | Word_int | Word_val -> lg
+ | Single -> assert false
+ | Double | Double_u -> "fld"
+ in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_int ofs}({emit_reg i.arg.(0)})\n`
+ | Lop(Istore(Single, Iindexed ofs, _)) ->
+ ` fmv.x.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}\n`;
+ ` fcvt.s.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}\n`;
+ ` fsw {emit_reg i.arg.(0)}, {emit_int ofs}({emit_reg i.arg.(1)})\n`;
+ ` fmv.d.x {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}\n`
+ | Lop(Istore(chunk, Iindexed ofs, _)) ->
+ let instr =
+ match chunk with
+ | Byte_unsigned | Byte_signed -> "sb"
+ | Sixteen_unsigned | Sixteen_signed -> "sh"
+ | Thirtytwo_unsigned | Thirtytwo_signed -> "sw"
+ | Word_int | Word_val -> stg
+ | Single -> assert false
+ | Double | Double_u -> "fsd"
+ in
+ ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int ofs}({emit_reg i.arg.(1)})\n`
+ | Lop(Ialloc {words = n; label_after_call_gc = label; _}) ->
+ let lbl_frame_lbl = record_frame_label ?label i.live false i.dbg in
+ let lbl_redo = new_label () in
+ let lbl_call_gc = new_label () in
+ `{emit_label lbl_redo}:\n`;
+ ` addi {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, -{emit_int n}\n`;
+ ` addi {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, {emit_int size_addr}\n`;
+ ` bltu {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_lim}, {emit_label lbl_call_gc}\n`;
+ call_gc_sites :=
+ { gc_lbl = lbl_call_gc;
+ gc_return_lbl = lbl_redo;
+ gc_frame_lbl = lbl_frame_lbl } :: !call_gc_sites
+ | Lop(Iintop(Icomp cmp)) ->
+ begin match cmp with
+ | Isigned Clt ->
+ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+ | Isigned Cge ->
+ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
+ | Isigned Cgt ->
+ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
+ | Isigned Cle ->
+ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
+ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
+ | Isigned Ceq | Iunsigned Ceq ->
+ ` sub {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+ ` seqz {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | Isigned Cne | Iunsigned Cne ->
+ ` sub {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+ ` snez {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | Iunsigned Clt ->
+ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+ | Iunsigned Cge ->
+ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
+ | Iunsigned Cgt ->
+ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
+ | Iunsigned Cle ->
+ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
+ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
+ end
+ | Lop(Iintop (Icheckbound {label_after_error = label; _})) ->
+ let lbl = bound_error_label ?label i.dbg in
+ ` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
+ | Lop(Iintop op) ->
+ let instr = name_for_intop op in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+ | Lop(Iintop_imm(Isub, n)) ->
+ ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
+ | Lop(Iintop_imm(Icomp _, _)) ->
+ fatal_error "Emit.emit_instr (Iintop_imm (Icomp _, _))"
+ | Lop(Iintop_imm(Icheckbound {label_after_error = label; _}, n)) ->
+ let lbl = bound_error_label ?label i.dbg in
+ ` li {emit_reg reg_tmp1}, {emit_int n}\n`;
+ ` bleu {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ | Lop(Iintop_imm(op, n)) ->
+ let instr = name_for_intop_imm op in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
+ | Lop(Inegf | Iabsf as op) ->
+ let instr = name_for_floatop1 op in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+ | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
+ let instr = name_for_floatop2 op in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+ | Lop(Ifloatofint) ->
+ let name = if rv64 then "fcvt.d.l" else "fcvt.d.w" in
+ ` {emit_string name} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+ | Lop(Iintoffloat) ->
+ let name = if rv64 then "fcvt.l.d" else "fcvt.w.d" in
+ ` {emit_string name} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+ | Lop(Ispecific sop) ->
+ let instr = name_for_specific sop in
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
+ | Lreloadretaddr ->
+ let n = frame_size () in
+ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`
+ | Lreturn ->
+ let n = frame_size() in
+ if n > 0 then
+ ` addi sp, sp, {emit_int n}\n`;
+ ` ret\n`
+ | Llabel lbl ->
+ `{emit_label lbl}:\n`
+ | Lbranch lbl ->
+ ` j {emit_label lbl}\n`
+ | Lcondbranch(tst, lbl) ->
+ begin match tst with
+ | Itruetest ->
+ ` bnez {emit_reg i.arg.(0)}, {emit_label lbl}\n`
+ | Ifalsetest ->
+ ` beqz {emit_reg i.arg.(0)}, {emit_label lbl}\n`
+ | Iinttest cmp ->
+ let name = match cmp with
+ | Iunsigned Ceq | Isigned Ceq -> "beq"
+ | Iunsigned Cne | Isigned Cne -> "bne"
+ | Iunsigned Cle -> "bleu" | Isigned Cle -> "ble"
+ | Iunsigned Cge -> "bgeu" | Isigned Cge -> "bge"
+ | Iunsigned Clt -> "bltu" | Isigned Clt -> "blt"
+ | Iunsigned Cgt -> "bgtu" | Isigned Cgt -> "bgt"
+ in
+ ` {emit_string name} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
+ | Iinttest_imm _ ->
+ fatal_error "Emit.emit_instr (Iinttest_imm _)"
+ | Ifloattest(cmp, neg) ->
+ let neg = match cmp with
+ | Ceq -> ` feq.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg
+ | Cne -> ` feq.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; not neg
+ | Clt -> ` flt.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg
+ | Cgt -> ` flt.d {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; neg
+ | Cle -> ` fle.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg
+ | Cge -> ` fle.d {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; neg
+ in
+ if neg then
+ ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ else
+ ` bnez {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ | Ioddtest ->
+ ` andi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, 1\n`;
+ ` bnez {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ | Ieventest ->
+ ` andi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, 1\n`;
+ ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ end
+ | Lcondbranch3(lbl0, lbl1, lbl2) ->
+ ` addi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, -1\n`;
+ begin match lbl0 with
+ | None -> ()
+ | Some lbl -> ` bltz {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ end;
+ begin match lbl1 with
+ | None -> ()
+ | Some lbl -> ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ end;
+ begin match lbl2 with
+ | None -> ()
+ | Some lbl -> ` bgtz {emit_reg reg_tmp1}, {emit_label lbl}\n`
+ end
+ | Lswitch jumptbl -> (* FIXME FIXME ? *)
+ let lbl = new_label() in
+ ` la {emit_reg reg_tmp1}, {emit_label lbl}\n`;
+ ` slli {emit_reg reg_tmp2}, {emit_reg i.arg.(0)}, 2\n`;
+ ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg reg_tmp2}\n`;
+ ` jr {emit_reg reg_tmp1}\n`;
+ `{emit_label lbl}:\n`;
+ for i = 0 to Array.length jumptbl - 1 do
+ ` j {emit_label jumptbl.(i)}\n`
+ done
+ | Lsetuptrap lbl ->
+ ` addi sp, sp, -16\n`;
+ ` jal {emit_label lbl}\n`
+ | Lpushtrap ->
+ stack_offset := !stack_offset + 16;
+ ` {emit_string stg} ra, {emit_int size_addr}(sp)\n`;
+ ` {emit_string stg} {emit_reg reg_trap}, 0(sp)\n`;
+ ` mv {emit_reg reg_trap}, sp\n`
+ | Lpoptrap ->
+ ` {emit_string lg} {emit_reg reg_trap}, 0(sp)\n`;
+ ` addi sp, sp, 16\n`;
+ stack_offset := !stack_offset - 16
+ | Lraise k ->
+ begin match !Clflags.debug, k with
+ | true, Cmm.Raise_withtrace ->
+ ` call {emit_symbol "caml_raise_exn"}\n`;
+ record_frame Reg.Set.empty true i.dbg
+ | false, _
+ | true, Cmm.Raise_notrace ->
+ ` mv sp, {emit_reg reg_trap}\n`;
+ ` {emit_string lg} {emit_reg reg_tmp1}, {emit_int size_addr}(sp)\n`;
+ ` {emit_string lg} {emit_reg reg_trap}, 0(sp)\n`;
+ ` addi sp, sp, 16\n`;
+ ` jalr {emit_reg reg_tmp1}\n`
+ end
+
+(* Emit a sequence of instructions *)
+
+let rec emit_all = function
+ | {desc = Lend} -> () | i -> emit_instr i; emit_all i.next
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+ function_name := fundecl.fun_name;
+ tailrec_entry_point := new_label();
+ stack_offset := 0;
+ call_gc_sites := [];
+ bound_error_sites := [];
+ float_literals := [];
+ ` .globl {emit_symbol fundecl.fun_name}\n`;
+ ` .type {emit_symbol fundecl.fun_name}, @function\n`;
+ ` {emit_string code_space}\n`;
+ ` .align 2\n`;
+ `{emit_symbol fundecl.fun_name}:\n`;
+ let n = frame_size() in
+ if n > 0 then
+ ` addi sp, sp, {emit_int(-n)}\n`;
+ if !contains_calls then
+ ` {emit_string stg} ra, {emit_int(n - size_addr)}(sp)\n`;
+ `{emit_label !tailrec_entry_point}:\n`;
+ emit_all fundecl.fun_body;
+ List.iter emit_call_gc !call_gc_sites;
+ List.iter emit_call_bound_error !bound_error_sites;
+ ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`;
+ (* Emit the float literals *)
+ if !float_literals <> [] then begin
+ ` {emit_string rodata_space}\n`;
+ ` .align 3\n`;
+ List.iter
+ (fun (f, lbl) ->
+ `{emit_label lbl}:\n`;
+ if rv64
+ then emit_float64_directive ".quad" f
+ else emit_float64_split_directive ".long" f)
+ !float_literals;
+ end
+
+(* Emission of data *)
+
+let declare_global_data s =
+ ` .globl {emit_symbol s}\n`;
+ ` .type {emit_symbol s}, @object\n`
+
+let emit_item = function
+ | Cglobal_symbol s ->
+ declare_global_data s
+ | Cdefine_symbol s ->
+ `{emit_symbol s}:\n`;
+ | Cint8 n ->
+ ` .byte {emit_int n}\n`
+ | Cint16 n ->
+ ` .short {emit_int n}\n`
+ | Cint32 n ->
+ ` .long {emit_nativeint n}\n`
+ | Cint n ->
+ ` {emit_string datag} {emit_nativeint n}\n`
+ | Csingle f ->
+ emit_float32_directive ".long" (Int32.bits_of_float f)
+ | Cdouble f ->
+ if rv64
+ then emit_float64_directive ".quad" (Int64.bits_of_float f)
+ else emit_float64_split_directive ".long" (Int64.bits_of_float f)
+ | Csymbol_address s ->
+ ` {emit_string datag} {emit_symbol s}\n`
+ | Cstring s ->
+ emit_bytes_directive " .byte " s
+ | Cskip n ->
+ if n > 0 then ` .space {emit_int n}\n`
+ | Calign n ->
+ ` .align {emit_int (Misc.log2 n)}\n`
+
+let data l =
+ ` {emit_string data_space}\n`;
+ List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+ (* Emit the beginning of the segments *)
+ let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
+ ` {emit_string data_space}\n`;
+ declare_global_data lbl_begin;
+ `{emit_symbol lbl_begin}:\n`;
+ let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
+ ` {emit_string code_space}\n`;
+ declare_global_data lbl_begin;
+ `{emit_symbol lbl_begin}:\n`
+
+let end_assembly() =
+ ` {emit_string code_space}\n`;
+ let lbl_end = Compilenv.make_symbol (Some "code_end") in
+ declare_global_data lbl_end;
+ `{emit_symbol lbl_end}:\n`;
+ ` .long 0\n`;
+ ` {emit_string data_space}\n`;
+ let lbl_end = Compilenv.make_symbol (Some "data_end") in
+ declare_global_data lbl_end;
+ `{emit_symbol lbl_end}:\n`;
+ ` {emit_string datag} 0\n`;
+ (* Emit the frame descriptors *)
+ ` {emit_string rodata_space}\n`;
+ let lbl = Compilenv.make_symbol (Some "frametable") in
+ declare_global_data lbl;
+ `{emit_symbol lbl}:\n`;
+ emit_frames
+ { efa_code_label = (fun l -> ` {emit_string datag} {emit_label l}\n`);
+ efa_data_label = (fun l -> ` {emit_string datag} {emit_label l}\n`);
+ efa_16 = (fun n -> ` .short {emit_int n}\n`);
+ efa_32 = (fun n -> ` .long {emit_int32 n}\n`);
+ efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`);
+ efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`);
+ efa_label_rel = (fun lbl ofs ->
+ ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`);
+ efa_def_label = (fun l -> `{emit_label l}:\n`);
+ efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000"))
+ }
diff --git a/asmcomp/riscv/proc.ml b/asmcomp/riscv/proc.ml
new file mode 100644
index 000000000..c0b0dcdb8
--- /dev/null
+++ b/asmcomp/riscv/proc.ml
@@ -0,0 +1,301 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Description of the RISC-V *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Integer register map:
+ zero always zero
+ ra return address
+ sp, gp, tp stack pointer, global pointer, thread pointer (preserved by C)
+ a0 - a7 0 - 7 arguments/results
+ s2 - s9 8 - 15 arguments/results (preserved by C)
+ t2 - t6 16 - 20 temporary
+ t0 21 temporary (used by assembler)
+ t1 22 temporary (reserved for code gen)
+ s0 23 frame pointer (preserved by C)
+ s1 24 trap pointer (preserved by C)
+ s10 25 allocation pointer (preserved by C)
+ s11 26 allocation limit (preserved by C)
+ Floating-point register map:
+ ft0 - ft7 100 - 107 temporary
+ fs0 - fs1 108 - 109 general purpose (preserved by C)
+ fa0 - fa7 110 - 117 arguments/results
+ fs2 - fs9 118 - 125 arguments/results (preserved by C)
+ fs10 - fs11 126 - 127 general purpose (preserved by C)
+ ft8 - ft11 128 - 131 temporary
+*)
+
+let int_reg_name =
+ [| "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7";
+ "s2"; "s3"; "s4"; "s5"; "s6"; "s7"; "s8"; "s9";
+ "t2"; "t3"; "t4"; "t5"; "t6";
+ "t0"; "t1";
+ "s0"; "s1"; "s10"; "s11" |]
+
+let float_reg_name =
+ [| "ft0"; "ft1"; "ft2"; "ft3"; "ft4"; "ft5"; "ft6"; "ft7";
+ "fs0"; "fs1";
+ "fa0"; "fa1"; "fa2"; "fa3"; "fa4"; "fa5"; "fa6"; "fa7";
+ "fs2"; "fs3"; "fs4"; "fs5"; "fs6"; "fs7"; "fs8"; "fs9"; "fs10"; "fs11";
+ "ft8"; "ft9"; "ft10"; "ft11" |]
+
+let num_register_classes = 2
+
+let register_class r =
+ match r.typ with
+ | Val | Int | Addr -> 0
+ | Float -> 1
+
+let num_available_registers = [| 21; 32 |]
+
+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.make 27 Reg.dummy in
+ for i = 0 to 26 do
+ v.(i) <- Reg.at_location Int (Reg i)
+ done;
+ v
+
+let hard_float_reg =
+ let v = Array.make 32 Reg.dummy in
+ for i = 0 to 31 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.make (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
+ | Val | 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 _ = fatal_error "Proc.loc_results: cannot call"
+
+let max_arguments_for_tailcalls = 16
+
+let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
+
+(* OCaml calling convention:
+ first integer args in a0 .. a7, s2 .. s9
+ first float args in fa0 .. fa7, fs2 .. fs9
+ remaining args on stack.
+ Return values in a0 .. a7, s2 .. s9 or fa0 .. fa7, fs2 .. fs9. *)
+
+let single_regs arg = Array.map (fun arg -> [| arg |]) arg
+let ensure_single_regs res =
+ Array.map (function
+ | [| res |] -> res
+ | _ -> failwith "proc.ensure_single_regs"
+ ) res
+
+let loc_arguments arg =
+ calling_conventions 0 15 110 125 outgoing arg
+
+let loc_parameters arg =
+ let (loc, _ofs) =
+ calling_conventions 0 15 110 125 incoming arg
+ in
+ loc
+
+let loc_results res =
+ let (loc, _ofs) =
+ calling_conventions 0 15 110 125 not_supported res
+ in
+ loc
+
+(* C calling convention:
+ first integer args in a0 .. a7
+ first float args in fa0 .. fa7
+ remaining args on stack.
+ Return values in a0 .. a1 or fa0 .. fa1. *)
+
+let external_calling_conventions
+ first_int last_int first_float last_float make_stack arg =
+ let loc = Array.make (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) with
+ | [| arg |] ->
+ begin match arg.typ with
+ | Val | 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 float;
+ incr int;
+ end else begin
+ loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
+ ofs := !ofs + size_float
+ end
+ end
+ | [| arg1; arg2 |] ->
+ (* Passing of 64-bit quantities to external functions on 32-bit
+ platform. *)
+ assert (size_int = 4);
+ begin match arg1.typ, arg2.typ with
+ | Int, Int ->
+ int := Misc.align !int 2;
+ if !int <= last_int - 1 then begin
+ let reg_lower = phys_reg !int in
+ let reg_upper = phys_reg (!int + 1) in
+ loc.(i) <- [| reg_lower; reg_upper |];
+ int := !int + 2
+ end else begin
+ let size_int64 = 8 in
+ ofs := Misc.align !ofs size_int64;
+ let ofs_lower = !ofs in
+ let ofs_upper = !ofs + size_int in
+ let stack_lower = stack_slot (make_stack ofs_lower) Int in
+ let stack_upper = stack_slot (make_stack ofs_upper) Int in
+ loc.(i) <- [| stack_lower; stack_upper |];
+ ofs := !ofs + size_int64
+ end
+ | _ ->
+ let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in
+ fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \
+ type(s) for multi-register argument: %s, %s"
+ (f arg1.typ) (f arg2.typ))
+ end
+ | _ ->
+ fatal_error "Proc.calling_conventions: bad number of register for \
+ multi-register argument"
+ done;
+ (loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *)
+
+let loc_external_arguments arg =
+ external_calling_conventions 0 7 110 117 outgoing arg
+
+let loc_external_results res =
+ let (loc, _ofs) =
+ external_calling_conventions 0 1 110 111 not_supported (single_regs res)
+ in
+ ensure_single_regs loc
+
+(* Exceptions are in GPR 3 *)
+
+let loc_exn_bucket = phys_reg 0
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _ = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =
+ Array.of_list(List.map phys_reg
+ [0; 1; 2; 3; 4; 5; 6; 7; 16; 17; 18; 19; 20; (* 21; 22; *)
+ 100; 101; 102; 103; 104; 105; 106; 107; 110; 111; 112; 113; 114; 115; 116;
+ 117; 128; 129; 130; 131])
+
+let destroyed_at_oper = function
+ | Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}) -> all_phys_regs
+ | Iop(Iextcall{alloc = false; _}) -> destroyed_at_c_call
+ | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+ | Iextcall _ -> 15
+ | _ -> 21
+
+let max_register_pressure = function
+ | Iextcall _ -> [| 15; 18 |]
+ | _ -> [| 21; 30 |]
+
+(* Pure operations (without any side effect besides updating their result
+ registers). *)
+
+let op_is_pure = function
+ | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+ | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+ | Ispecific(Imultaddf _ | Imultsubf _) -> true
+ | _ -> true
+
+(* 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)
+
+let init () = ()
diff --git a/asmcomp/riscv/reload.ml b/asmcomp/riscv/reload.ml
new file mode 100644
index 000000000..85b970342
--- /dev/null
+++ b/asmcomp/riscv/reload.ml
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Reloading for the RISC-V *)
+
+let fundecl f =
+ (new Reloadgen.reload_generic)#fundecl f
diff --git a/asmcomp/riscv/scheduling.ml b/asmcomp/riscv/scheduling.ml
new file mode 100644
index 000000000..e436be1cc
--- /dev/null
+++ b/asmcomp/riscv/scheduling.ml
@@ -0,0 +1,19 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Instruction scheduling for the RISC-V *)
+
+let _ = let module M = Schedgen in () (* to create a dependency *)
+
+(* Scheduling is turned off. *)
+
+let fundecl f = f
diff --git a/asmcomp/riscv/selection.ml b/asmcomp/riscv/selection.ml
new file mode 100644
index 000000000..60ec5cb4e
--- /dev/null
+++ b/asmcomp/riscv/selection.ml
@@ -0,0 +1,85 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar <n.oje.bar@gmail.com> *)
+(* *)
+(* Copyright 2016 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. *)
+(* *)
+(***********************************************************************)
+
+(* Instruction selection for the RISC-V processor *)
+
+open Cmm
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+class selector = object (self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate n = (n <= 0x7FF) && (n >= -0x800)
+
+method select_addressing _ = function
+ | Cop(Cadda, [arg; Cconst_int n]) when self#is_immediate n ->
+ (Iindexed n, arg)
+ | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when self#is_immediate n ->
+ (Iindexed n, Cop(Caddi, [arg1; arg2]))
+ | arg ->
+ (Iindexed 0, arg)
+
+method! select_operation op args =
+ match (op, args) with
+ (* RISC-V does not support immediate operands for multiply high *)
+ | (Cmulhi, _) -> (Iintop Imulh, args)
+ (* The and, or and xor instructions have a different range of immediate
+ operands than the other instructions *)
+ | (Cand, _) -> self#select_logical Iand args
+ | (Cor, _) -> self#select_logical Ior args
+ | (Cxor, _) -> self#select_logical Ixor args
+ (* Recognize (neg-)mult-add and (neg-)mult-sub instructions *)
+ | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3])
+ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
+ (Ispecific (Imultaddf false), [arg1; arg2; arg3])
+ | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
+ (Ispecific (Imultsubf false), [arg1; arg2; arg3])
+ | (Cnegf, [Cop(Csubf, [Cop(Cmulf, [arg1; arg2]); arg3])]) ->
+ (Ispecific (Imultsubf true), [arg1; arg2; arg3])
+ | (Cnegf, [Cop(Caddf, [Cop(Cmulf, [arg1; arg2]); arg3])]) ->
+ (Ispecific (Imultaddf true), [arg1; arg2; arg3])
+ (* RISC-V does not support immediate operands for comparison operators *)
+ | (Ccmpi comp, args) -> (Iintop(Icomp (Isigned comp)), args)
+ | (Ccmpa comp, args) -> (Iintop(Icomp (Iunsigned comp)), args)
+ | (Cmuli, _) -> (Iintop Imul, args)
+ | _ ->
+ super#select_operation op args
+
+method select_logical op = function
+ | [arg; Cconst_int n] when n >= 0 && n <= 0xFFF ->
+ (Iintop_imm(op, n), [arg])
+ | [Cconst_int n; arg] when n >= 0 && n <= 0xFFF ->
+ (Iintop_imm(op, n), [arg])
+ | args ->
+ (Iintop op, args)
+
+(* Instruction selection for conditionals *)
+
+method! select_condition = function
+ | Cop(Ccmpi cmp, args) ->
+ (Iinttest(Isigned cmp), Ctuple args)
+ | Cop(Ccmpa cmp, args) ->
+ (Iinttest(Iunsigned cmp), Ctuple args)
+ | Cop(Ccmpf cmp, args) ->
+ (Ifloattest(cmp, false), Ctuple args)
+ | Cop(Cand, [arg; Cconst_int 1]) ->
+ (Ioddtest, arg)
+ | arg ->
+ (Itruetest, arg)
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmrun/riscv.S b/asmrun/riscv.S
new file mode 100644
index 000000000..a82048efc
--- /dev/null
+++ b/asmrun/riscv.S
@@ -0,0 +1,424 @@
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Nicolas Ojeda Bar <n.oje.bar@gmail.com> */
+/* */
+/* 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. */
+/* */
+/***********************************************************************/
+
+/* Asm part of the runtime system, RISC-V processor, 64-bit mode */
+/* Must be preprocessed by cpp */
+
+#define TRAP_PTR s1
+#define ALLOC_PTR s10
+#define ALLOC_LIMIT s11
+#define TMP0 t0
+#define TMP1 t1
+#define ARG t2
+
+#if defined(MODEL_riscv64)
+#define store sd
+#define load ld
+#define WSZ 8
+#else
+#define store sw
+#define load lw
+#define WSZ 4
+#endif
+
+#if defined(__PIC__)
+ .option pic
+#else
+ .option nopic
+#endif
+
+ .section .text
+/* Invoke the garbage collector. */
+
+ .globl caml_system__code_begin
+caml_system__code_begin:
+
+ .align 2
+ .globl caml_call_gc
+ .type caml_call_gc, @function
+caml_call_gc:
+ /* Record return address */
+ store ra, caml_last_return_address, TMP0
+ /* Record lowest stack address */
+ mv TMP1, sp
+ store sp, caml_bottom_of_stack, TMP0
+.Lcaml_call_gc:
+ /* Set up stack space, saving return address */
+ /* (1 reg for RA, 1 reg for FP, 21 allocatable int regs, 20 caller-save float regs) * 8 */
+ /* + 1 for alignment */
+ addi sp, sp, -0x160
+ mv s0, sp
+ store ra, 0x8(sp)
+ store s0, 0x0(sp)
+ /* Save allocatable integer registers on the stack,
+ in the order given in proc.ml */
+ store a0, 0x10(sp)
+ store a1, 0x18(sp)
+ store a2, 0x20(sp)
+ store a3, 0x28(sp)
+ store a4, 0x30(sp)
+ store a5, 0x38(sp)
+ store a6, 0x40(sp)
+ store a7, 0x48(sp)
+ store s2, 0x50(sp)
+ store s3, 0x58(sp)
+ store s4, 0x60(sp)
+ store s5, 0x68(sp)
+ store s6, 0x70(sp)
+ store s7, 0x78(sp)
+ store s8, 0x80(sp)
+ store s9, 0x88(sp)
+ store t2, 0x90(sp)
+ store t3, 0x98(sp)
+ store t4, 0xa0(sp)
+ store t5, 0xa8(sp)
+ store t6, 0xb0(sp)
+ /* Save caller-save floating-point registers on the stack
+ (callee-saves are preserved by caml_garbage_collection) */
+ fsd ft0, 0xb8(sp)
+ fsd ft1, 0xc0(sp)
+ fsd ft2, 0xc8(sp)
+ fsd ft3, 0xd0(sp)
+ fsd ft4, 0xd8(sp)
+ fsd ft5, 0xe0(sp)
+ fsd ft6, 0xe8(sp)
+ fsd ft7, 0xf0(sp)
+ fsd fa0, 0xf8(sp)
+ fsd fa1, 0x100(sp)
+ fsd fa2, 0x108(sp)
+ fsd fa3, 0x110(sp)
+ fsd fa4, 0x118(sp)
+ fsd fa5, 0x120(sp)
+ fsd fa6, 0x128(sp)
+ fsd fa7, 0x130(sp)
+ fsd ft8, 0x138(sp)
+ fsd ft9, 0x140(sp)
+ fsd ft9, 0x148(sp)
+ fsd ft10, 0x150(sp)
+ fsd ft11, 0x158(sp)
+ /* Store pointer to saved integer registers in caml_gc_regs */
+ addi TMP1, sp, 16
+ store TMP1, caml_gc_regs, TMP0
+ /* Save current allocation pointer for debugging purposes */
+ store ALLOC_PTR, caml_young_ptr, TMP0
+ /* Save trap pointer in case an exception is raised during GC */
+ store TRAP_PTR, caml_exception_pointer, TMP0
+ /* Call the garbage collector */
+ call caml_garbage_collection
+ /* Restore registers */
+ load a0, 0x10(sp)
+ load a1, 0x18(sp)
+ load a2, 0x20(sp)
+ load a3, 0x28(sp)
+ load a4, 0x30(sp)
+ load a5, 0x38(sp)
+ load a6, 0x40(sp)
+ load a7, 0x48(sp)
+ load s2, 0x50(sp)
+ load s3, 0x58(sp)
+ load s4, 0x60(sp)
+ load s5, 0x68(sp)
+ load s6, 0x70(sp)
+ load s7, 0x78(sp)
+ load s8, 0x80(sp)
+ load s9, 0x88(sp)
+ load t2, 0x90(sp)
+ load t3, 0x98(sp)
+ load t4, 0xa0(sp)
+ load t5, 0xa8(sp)
+ load t6, 0xb0(sp)
+ fld ft0, 0xb8(sp)
+ fld ft1, 0xc0(sp)
+ fld ft2, 0xc8(sp)
+ fld ft3, 0xd0(sp)
+ fld ft4, 0xd8(sp)
+ fld ft5, 0xe0(sp)
+ fld ft6, 0xe8(sp)
+ fld ft7, 0xf0(sp)
+ fld fa0, 0xf8(sp)
+ fld fa1, 0x100(sp)
+ fld fa2, 0x108(sp)
+ fld fa3, 0x110(sp)
+ fld fa4, 0x118(sp)
+ fld fa5, 0x120(sp)
+ fld fa6, 0x128(sp)
+ fld fa7, 0x130(sp)
+ fld ft8, 0x138(sp)
+ fld ft9, 0x140(sp)
+ fld ft9, 0x148(sp)
+ fld ft10, 0x150(sp)
+ fld ft11, 0x158(sp)
+ /* Reload new allocation pointer and allocation limit */
+ load ALLOC_PTR, caml_young_ptr
+ load ALLOC_LIMIT, caml_young_limit
+ /* Free stack space and return to caller */
+ load ra, 0x8(sp)
+ load s0, 0x0(sp)
+ addi sp, sp, 0x160
+ ret
+ .size caml_call_gc, .-caml_call_gc
+
+/* Call a C function from OCaml */
+/* Function to call is in ARG */
+
+ .align 2
+ .globl caml_c_call
+ .type caml_c_call, @function
+caml_c_call:
+ /* Preserve return address in callee-save register s2 */
+ mv s2, ra
+ /* Record lowest stack address and return address */
+ store ra, caml_last_return_address, TMP0
+ store sp, caml_bottom_of_stack, TMP0
+ /* Make the exception handler alloc ptr available to the C code */
+ store ALLOC_PTR, caml_young_ptr, TMP0
+ store TRAP_PTR, caml_exception_pointer, TMP0
+ /* Call the function */
+ jalr ARG
+ /* Reload alloc ptr and alloc limit */
+ load ALLOC_PTR, caml_young_ptr
+ load TRAP_PTR, caml_exception_pointer
+ /* Return */
+ jr s2
+ .size caml_c_call, .-caml_c_call
+
+/* Raise an exception from OCaml */
+ .align 2
+ .globl caml_raise_exn
+ .type caml_raise_exn, @function
+caml_raise_exn:
+ /* Test if backtrace is active */
+ load TMP1, caml_backtrace_active
+ bnez TMP1, 2f
+1: /* Cut stack at current trap handler */
+ mv sp, TRAP_PTR
+ /* Pop previous handler and jump to it */
+ load TMP1, 8(sp)
+ load TRAP_PTR, 0(sp)
+ addi sp, sp, 16
+ jr TMP1
+2: /* Preserve exception bucket in callee-save register s2 */
+ mv s2, a0
+ /* Stash the backtrace */
+ mv a1, ra
+ mv a2, sp
+ mv a3, TRAP_PTR
+ call caml_stash_backtrace
+ /* Restore exception bucket and raise */
+ mv a0, s2
+ j 1b
+ .size caml_raise_exn, .-caml_raise_exn
+
+ .globl caml_reraise_exn
+ .type caml_reraise_exn, @function
+
+/* Raise an exception from C */
+
+ .align 2
+ .globl caml_raise_exception
+ .type caml_raise_exception, @function
+caml_raise_exception:
+ load TRAP_PTR, caml_exception_pointer
+ load ALLOC_PTR, caml_young_ptr
+ load ALLOC_LIMIT, caml_young_limit
+ load TMP1, caml_backtrace_active
+ bnez TMP1, 2f
+1: /* Cut stack at current trap handler */
+ mv sp, TRAP_PTR
+ load TMP1, 8(sp)
+ load TRAP_PTR, 0(sp)
+ addi sp, sp, 16
+ jr TMP1
+2: /* Preserve exception bucket in callee-save register s2 */
+ mv s2, a0
+ load a1, caml_last_return_address
+ load a2, caml_bottom_of_stack
+ mv a3, TRAP_PTR
+ call caml_stash_backtrace
+ mv a0, s2
+ j 1b
+ .size caml_raise_exception, .-caml_raise_exception
+
+/* Start the OCaml program */
+
+ .align 2
+ .globl caml_start_program
+ .type caml_start_program, @function
+caml_start_program:
+
+ la ARG, caml_program
+ /* Code shared with caml_callback* */
+ /* Address of OCaml code to call is in ARG */
+ /* Arguments to the OCaml code are in a0 ... a7 */
+.Ljump_to_caml:
+ /* Set up stack frame and save callee-save registers */
+ addi sp, sp, -0xd0
+ store ra, 0xc0(sp)
+ store s0, 0x0(sp)
+ store s1, 0x8(sp)
+ store s2, 0x10(sp)
+ store s3, 0x18(sp)
+ store s4, 0x20(sp)
+ store s5, 0x28(sp)
+ store s6, 0x30(sp)
+ store s7, 0x38(sp)
+ store s8, 0x40(sp)
+ store s9, 0x48(sp)
+ store s10, 0x50(sp)
+ store s11, 0x58(sp)
+ fsd fs0, 0x60(sp)
+ fsd fs1, 0x68(sp)
+ fsd fs2, 0x70(sp)
+ fsd fs3, 0x78(sp)
+ fsd fs4, 0x80(sp)
+ fsd fs5, 0x88(sp)
+ fsd fs6, 0x90(sp)
+ fsd fs7, 0x98(sp)
+ fsd fs8, 0xa0(sp)
+ fsd fs9, 0xa8(sp)
+ fsd fs10, 0xb0(sp)
+ fsd fs11, 0xb8(sp)
+ addi sp, sp, -32
+ /* Setup a callback link on the stack */
+ load TMP1, caml_bottom_of_stack
+ store TMP1, 0(sp)
+ load TMP1, caml_last_return_address
+ store TMP1, 8(sp)
+ load TMP1, caml_gc_regs
+ store TMP1, 16(sp)
+ /* set up a trap frame */
+ addi sp, sp, -16
+ load TMP1, caml_exception_pointer
+ store TMP1, 0(sp)
+ lla TMP0, .Ltrap_handler
+ store TMP0, 8(sp)
+ mv TRAP_PTR, sp
+ load ALLOC_PTR, caml_young_ptr
+ load ALLOC_LIMIT, caml_young_limit
+ store x0, caml_last_return_address, TMP0
+ jalr ARG
+.Lcaml_retaddr: /* pop trap frame, restoring caml_exception_pointer */
+ load TMP1, 0(sp)
+ store TMP1, caml_exception_pointer, TMP0
+ addi sp, sp, 16
+.Lreturn_result: /* pop callback link, restoring global variables */
+ load TMP1, 0(sp)
+ store TMP1, caml_bottom_of_stack, TMP0
+ load TMP1, 8(sp)
+ store TMP1, caml_last_return_address, TMP0
+ load TMP1, 16(sp)
+ store TMP1, caml_gc_regs, TMP0
+ addi sp, sp, 32
+ /* Update allocation pointer */
+ store ALLOC_PTR, caml_young_ptr, TMP0
+ /* reload callee-save registers and return */
+ load ra, 0xc0(sp)
+ load s0, 0x0(sp)
+ load s1, 0x8(sp)
+ load s2, 0x10(sp)
+ load s3, 0x18(sp)
+ load s4, 0x20(sp)
+ load s5, 0x28(sp)
+ load s6, 0x30(sp)
+ load s7, 0x38(sp)
+ load s8, 0x40(sp)
+ load s9, 0x48(sp)
+ load s10, 0x50(sp)
+ load s11, 0x58(sp)
+ fld fs0, 0x60(sp)
+ fld fs1, 0x68(sp)
+ fld fs2, 0x70(sp)
+ fld fs3, 0x78(sp)
+ fld fs4, 0x80(sp)
+ fld fs5, 0x88(sp)
+ fld fs6, 0x90(sp)
+ fld fs7, 0x98(sp)
+ fld fs8, 0xa0(sp)
+ fld fs9, 0xa8(sp)
+ fld fs10, 0xb0(sp)
+ fld fs11, 0xb8(sp)
+ addi sp, sp, 0xd0
+ ret
+.Ltrap_handler:
+ store TRAP_PTR, caml_exception_pointer, TMP0
+ ori a0, a0, 2
+ j .Lreturn_result
+ .size caml_start_program, .-caml_start_program
+
+/* Callback from C to OCaml */
+
+ .align 2
+ .globl caml_callback_exn
+ .type caml_callback_exn, @function
+caml_callback_exn:
+ /* Initial shuffling of arguments (a0 = closure, a1 = first arg) */
+ mv TMP1, a0
+ mv a0, a1 /* a0 = first arg */
+ mv a1, TMP1 /* a1 = closure environment */
+ load ARG, 0(TMP1) /* code pointer */
+ j .Ljump_to_caml
+ .size caml_callback_exn, .-caml_callback_exn
+
+ .align 2
+ .globl caml_callback2_exn
+ .type caml_callback2_exn, @function
+caml_callback2_exn:
+ /* Initial shuffling of arguments (a0 = closure, a1 = arg1, a2 = arg2) */
+ mv TMP1, a0
+ mv a0, a1
+ mv a1, a2
+ mv a2, TMP1
+ la ARG, caml_apply2
+ j .Ljump_to_caml
+ .size caml_callback2_exn, .-caml_callback2_exn
+
+ .align 2
+ .globl caml_callback3_exn
+ .type caml_callback3_exn, @function
+caml_callback3_exn:
+ /* Initial shuffling of argumnets */
+ /* (a0 = closure, a1 = arg1, a2 = arg2, a3 = arg3) */
+ mv TMP1, a0
+ mv a0, a1
+ mv a1, a2
+ mv a2, a3
+ mv a3, TMP1
+ la ARG, caml_apply3
+ j .Ljump_to_caml
+ .size caml_callback3_exn, .-caml_callback3_exn
+
+ .align 2
+ .globl caml_ml_array_bound_error
+ .type caml_ml_array_bound_error, @function
+caml_ml_array_bound_error:
+ /* Load address of [caml_array_bound_error] in ARG */
+ la ARG, caml_array_bound_error
+ /* Call that function */
+ j caml_c_call
+
+ .globl caml_system__code_end
+caml_system__code_end:
+
+/* GC roots for callback */
+
+ .section .data
+ .align 3
+ .globl caml_system__frametable
+ .type caml_system__frametable, @object
+caml_system__frametable:
+ .quad 1 /* one descriptor */
+ .quad .Lcaml_retaddr /* return address into callback */
+ .short -1 /* negative frame size => use callback link */
+ .short 0 /* no roots */
+ .align 3
+ .size caml_system__frametable, .-caml_system__frametable
diff --git a/byterun/caml/stack.h b/byterun/caml/stack.h
index fd9d528e9..781c2517b 100644
--- a/byterun/caml/stack.h
+++ b/byterun/caml/stack.h
@@ -75,6 +75,11 @@
#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
#endif
+#ifdef TARGET_riscv /* FIXME FIXME */
+#define Saved_return_address(sp) *((intnat *)((sp) - 8))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
+#endif
+
/* Structure of OCaml callback contexts */
struct caml_context {
diff --git a/configure b/configure
index d53d90367..04acb43be 100755
--- a/configure
+++ b/configure
@@ -820,6 +820,7 @@ if test $with_sharedlibs = "yes"; then
arm*-*-freebsd*) natdynlink=true;;
earm*-*-netbsd*) natdynlink=true;;
aarch64-*-linux*) natdynlink=true;;
+ riscv*-*-linux*) natdynlink=true;;
esac
fi
@@ -889,6 +890,8 @@ case "$target" in
x86_64-*-mingw*) arch=amd64; system=mingw;;
aarch64-*-linux*) arch=arm64; system=linux;;
x86_64-*-cygwin*) arch=amd64; system=cygwin;;
+ riscv32-*-linux*) arch=riscv; model=riscv32; system=linux;;
+ riscv64-*-linux*) arch=riscv; model=riscv64; system=linux;;
esac
# Some platforms exist both in 32-bit and 64-bit variants, not distinguished
@@ -964,7 +967,7 @@ case "$arch,$system" in
aspp="${TOOLPREF}cc -c";;
*,freebsd) as="${TOOLPREF}as"
aspp="${TOOLPREF}cc -c";;
- amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*)
+ amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*|riscv,*)
as="${TOOLPREF}as"
aspp="${TOOLPREF}gcc -c";;
esac
--
2.13.1
Reference in New Issue View Git Blame Copy Permalink