From a2dcfff43b33014a111e86f3c59f9911e933adfb Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 4 May 2020 10:16:53 +0100 Subject: [PATCH] Move to OCaml 4.11.0+dev2-2020-04-22. - Backport upstream RISC-V backend from 4.12 + fixes. - Enable tests on riscv64. - Disable ocaml-instr-* tools on riscv64. --- 0001-Don-t-add-rpaths-to-libraries.patch | 4 +- ...-Allow-user-defined-C-compiler-flags.patch | 6 +- ...-incorrect-assumption-about-cross-co.patch | 8 +- ...Remove-configure-from-.gitattributes.patch | 4 +- ...-Add-RISC-V-native-code-backend-9441.patch | 2012 +++++++++++++++++ ...-request-9457-from-dra27-fix-mod_use.patch | 174 -- ...st-9463-from-lthls-fix_int64_cmm_typ.patch | 134 -- 0006-Support-FP-reg-int-reg-moves.patch | 34 + ...-conventions-to-the-RISC-V-ELF-psABI.patch | 59 + ...nit-names-with-special-characters-94.patch | 55 - ocaml.spec | 32 +- sources | 2 +- 12 files changed, 2138 insertions(+), 386 deletions(-) create mode 100644 0005-Add-RISC-V-native-code-backend-9441.patch delete mode 100644 0005-Merge-pull-request-9457-from-dra27-fix-mod_use.patch delete mode 100644 0006-Merge-pull-request-9463-from-lthls-fix_int64_cmm_typ.patch create mode 100644 0006-Support-FP-reg-int-reg-moves.patch create mode 100644 0007-Update-C-calling-conventions-to-the-RISC-V-ELF-psABI.patch delete mode 100644 0007-x86-asm-handle-unit-names-with-special-characters-94.patch diff --git a/0001-Don-t-add-rpaths-to-libraries.patch b/0001-Don-t-add-rpaths-to-libraries.patch index 2f9e58c..281cb7c 100644 --- a/0001-Don-t-add-rpaths-to-libraries.patch +++ b/0001-Don-t-add-rpaths-to-libraries.patch @@ -1,4 +1,4 @@ -From 14d63e7a96ab39598f7c42b8513c914253afb173 Mon Sep 17 00:00:00 2001 +From 1b1a2ad3294327e5bbbc753f306d1199b0a2a583 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 24 Jun 2014 10:00:15 +0100 Subject: [PATCH 1/7] Don't add rpaths to libraries. @@ -8,7 +8,7 @@ Subject: [PATCH 1/7] Don't add rpaths to libraries. 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/Makefile b/tools/Makefile -index 8bd51bfd8..b34cbbf32 100644 +index 96a4244cc..076411a91 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -153,8 +153,8 @@ $(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo \ diff --git a/0002-configure-Allow-user-defined-C-compiler-flags.patch b/0002-configure-Allow-user-defined-C-compiler-flags.patch index dee5644..3ffd213 100644 --- a/0002-configure-Allow-user-defined-C-compiler-flags.patch +++ b/0002-configure-Allow-user-defined-C-compiler-flags.patch @@ -1,4 +1,4 @@ -From 65456b148ad6532a6b0086ba5812b67c0371e768 Mon Sep 17 00:00:00 2001 +From 8ea0bc7713a89cd6340e35b4dae048be63c50aec Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 29 May 2012 20:44:18 +0100 Subject: [PATCH 2/7] configure: Allow user defined C compiler flags. @@ -8,10 +8,10 @@ Subject: [PATCH 2/7] configure: Allow user defined C compiler flags. 1 file changed, 4 insertions(+) diff --git a/configure.ac b/configure.ac -index e84dc0431..1687918a2 100644 +index fbd49c1ee..a35da2040 100644 --- a/configure.ac +++ b/configure.ac -@@ -608,6 +608,10 @@ AS_CASE([$host], +@@ -609,6 +609,10 @@ AS_CASE([$host], internal_cflags="$gcc_warnings"], [common_cflags="-O"])]) diff --git a/0003-configure-Remove-incorrect-assumption-about-cross-co.patch b/0003-configure-Remove-incorrect-assumption-about-cross-co.patch index 3c49bdd..2b6d384 100644 --- a/0003-configure-Remove-incorrect-assumption-about-cross-co.patch +++ b/0003-configure-Remove-incorrect-assumption-about-cross-co.patch @@ -1,4 +1,4 @@ -From 0b1b91841a3a227321f8e155ed932893e285b429 Mon Sep 17 00:00:00 2001 +From 39df379f1aa139a073d7b436bb9bd33ef2f70caf Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 26 Apr 2019 16:16:29 +0100 Subject: [PATCH 3/7] configure: Remove incorrect assumption about @@ -10,10 +10,10 @@ See https://github.com/ocaml/ocaml/issues/8647#issuecomment-487094390 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/configure.ac b/configure.ac -index 1687918a2..01edbff17 100644 +index a35da2040..4c9358897 100644 --- a/configure.ac +++ b/configure.ac -@@ -510,10 +510,11 @@ AS_IF( +@@ -511,10 +511,11 @@ AS_IF( # Are we building a cross-compiler @@ -29,7 +29,7 @@ index 1687918a2..01edbff17 100644 # Checks for programs -@@ -996,7 +997,7 @@ AS_IF([test $arch != "none" && $arch64 ], +@@ -1018,7 +1019,7 @@ AS_CASE([$arch], # Assembler diff --git a/0004-Remove-configure-from-.gitattributes.patch b/0004-Remove-configure-from-.gitattributes.patch index 6058177..eb562e5 100644 --- a/0004-Remove-configure-from-.gitattributes.patch +++ b/0004-Remove-configure-from-.gitattributes.patch @@ -1,4 +1,4 @@ -From 0b805df7403257a71b9852deb2f468aac16133b0 Mon Sep 17 00:00:00 2001 +From e829051c3b35920db3c5e0dd913026f556448675 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Sat, 18 Jan 2020 11:31:27 +0000 Subject: [PATCH 4/7] Remove configure from .gitattributes. @@ -9,7 +9,7 @@ It's not a binary file. 1 file changed, 4 deletions(-) diff --git a/.gitattributes b/.gitattributes -index db37bfbe5..b6e540188 100644 +index 200eb49c6..d871764de 100644 --- a/.gitattributes +++ b/.gitattributes @@ -29,10 +29,6 @@ diff --git a/0005-Add-RISC-V-native-code-backend-9441.patch b/0005-Add-RISC-V-native-code-backend-9441.patch new file mode 100644 index 0000000..f466fdd --- /dev/null +++ b/0005-Add-RISC-V-native-code-backend-9441.patch @@ -0,0 +1,2012 @@ +From 1a0ca036e40cbd701cbe3f0e5cf5e2a6b6d4c804 Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= +Date: Fri, 24 Apr 2020 16:04:50 +0200 +Subject: [PATCH 5/7] Add RISC-V native-code backend (#9441) + +This is a port of ocamlopt for the RISC-V processor in 64-bit mode. + +(cherry picked from commit 8f3833c4d0ef656c826359f4137c1eb3d46ea0ef) +--- + Changes | 3 + + Makefile | 2 +- + README.adoc | 1 + + asmcomp/riscv/CSE.ml | 39 ++ + asmcomp/riscv/NOTES.md | 18 + + asmcomp/riscv/arch.ml | 87 +++++ + asmcomp/riscv/emit.mlp | 684 +++++++++++++++++++++++++++++++++ + asmcomp/riscv/proc.ml | 334 ++++++++++++++++ + asmcomp/riscv/reload.ml | 19 + + asmcomp/riscv/scheduling.ml | 22 ++ + asmcomp/riscv/selection.ml | 75 ++++ + configure | 8 +- + configure.ac | 9 +- + runtime/caml/stack.h | 5 + + runtime/riscv.S | 423 ++++++++++++++++++++ + testsuite/tools/asmgen_riscv.S | 89 +++++ + 16 files changed, 1812 insertions(+), 6 deletions(-) + create mode 100644 asmcomp/riscv/CSE.ml + create mode 100644 asmcomp/riscv/NOTES.md + 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 runtime/riscv.S + create mode 100644 testsuite/tools/asmgen_riscv.S + +diff --git a/Changes b/Changes +index d92ade2df..b7336c154 100644 +--- a/Changes ++++ b/Changes +@@ -121,6 +121,9 @@ OCaml 4.11 + - #9392: Visit registers at most once in Coloring.iter_preferred. + (Stephen Dolan, review by Pierre Chambart and Xavier Leroy) + ++- #9441: Add RISC-V RV64G native-code backend. ++ (Nicolás Ojeda Bär, review by Xavier Leroy and Gabriel Scherer) ++ + ### Standard library: + + - #9077: Add Seq.cons and Seq.append +diff --git a/Makefile b/Makefile +index fc9b179a4..2984178a8 100644 +--- a/Makefile ++++ b/Makefile +@@ -51,7 +51,7 @@ include stdlib/StdlibModules + + CAMLC=$(BOOT_OCAMLC) -g -nostdlib -I boot -use-prims runtime/primitives + CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink +-ARCHES=amd64 i386 arm arm64 power s390x ++ARCHES=amd64 i386 arm arm64 power s390x riscv + INCLUDES=-I utils -I parsing -I typing -I bytecomp -I file_formats \ + -I lambda -I middle_end -I middle_end/closure \ + -I middle_end/flambda -I middle_end/flambda/base_types \ +diff --git a/README.adoc b/README.adoc +index 84eb169b2..4365c2f12 100644 +--- a/README.adoc ++++ b/README.adoc +@@ -62,6 +62,7 @@ compiler currently runs on the following platforms: + | ARM 32 bits | Linux | FreeBSD, NetBSD, OpenBSD + | Power 64 bits | Linux | + | Power 32 bits | | Linux ++| RISC-V 64 bits | Linux | + | IBM Z (s390x) | Linux | + |==== + +diff --git a/asmcomp/riscv/CSE.ml b/asmcomp/riscv/CSE.ml +new file mode 100644 +index 000000000..6aed1c07f +--- /dev/null ++++ b/asmcomp/riscv/CSE.ml +@@ -0,0 +1,39 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* 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/NOTES.md b/asmcomp/riscv/NOTES.md +new file mode 100644 +index 000000000..3b00d08ec +--- /dev/null ++++ b/asmcomp/riscv/NOTES.md +@@ -0,0 +1,18 @@ ++# Supported platforms ++ ++RISC-V in 64-bit mode, general variant, a.k.a `RV64G`. ++ ++Debian architecture name: `riscv64` ++ ++# Reference documents ++ ++* Instruction set specification: ++ - https://riscv.org/specifications/isa-spec-pdf/ ++ - https://rv8.io/isa ++ ++* ELF ABI specification: ++ - https://github.com/riscv/riscv-elf-psabi-doc/blob/master/riscv-elf.md ++ ++* Assembly language manual ++ - https://github.com/riscv/riscv-asm-manual/blob/master/riscv-asm.md ++ - https://rv8.io/asm +diff --git a/asmcomp/riscv/arch.ml b/asmcomp/riscv/arch.ml +new file mode 100644 +index 000000000..c6ade5279 +--- /dev/null ++++ b/asmcomp/riscv/arch.ml +@@ -0,0 +1,87 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* 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 *) ++ ++let is_immediate n = ++ (n <= 0x7FF) && (n >= -0x800) ++ ++(* Sizes, endianness *) ++ ++let big_endian = false ++ ++let size_addr = 8 ++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..dc652de42 +--- /dev/null ++++ b/asmcomp/riscv/emit.mlp +@@ -0,0 +1,684 @@ ++# 2 "asmcomp/riscv/emit.mlp" ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* Emission of RISC-V assembly code *) ++ ++open Cmm ++open Arch ++open Proc ++open Reg ++open Mach ++open Linear ++open Emitaux ++ ++(* Layout of the stack. The stack is kept 16-aligned. *) ++ ++let stack_offset = ref 0 ++ ++let num_stack_slots = Array.make Proc.num_register_classes 0 ++ ++let prologue_required = ref false ++ ++let contains_calls = ref false ++ ++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 = ++ emit_symbol '$' s ++ ++let emit_jump op s = ++ if !Clflags.dlcode || !Clflags.pic_code ++ then `{emit_string op} {emit_symbol s}@plt` ++ else `{emit_string op} {emit_symbol s}` ++ ++let emit_call = emit_jump "call" ++let emit_tail = emit_jump "tail" ++ ++(* Output a label *) ++ ++let emit_label lbl = ++ emit_string ".L"; emit_int lbl ++ ++(* Section switching *) ++ ++let data_space = ++ ".section .data" ++ ++let code_space = ++ ".section .text" ++ ++let rodata_space = ++ ".section .rodata" ++ ++(* Names for special regs *) ++ ++let reg_tmp = phys_reg 22 ++let reg_t2 = phys_reg 16 ++let reg_domain_state_ptr = phys_reg 23 ++let reg_trap = phys_reg 24 ++let reg_alloc_ptr = phys_reg 25 ++let reg_alloc_lim = phys_reg 26 ++ ++(* Output a pseudo-register *) ++ ++let reg_name = function ++ | {loc = Reg r} -> register_name r ++ | _ -> Misc.fatal_error "Emit.reg_name" ++ ++let emit_reg r = ++ emit_string (reg_name r) ++ ++(* Adjust sp by the given byte amount *) ++ ++let emit_stack_adjustment = function ++ | 0 -> () ++ | n when is_immediate n -> ++ ` addi sp, sp, {emit_int n}\n` ++ | n -> ++ ` li {emit_reg reg_tmp}, {emit_int n}\n`; ++ ` add sp, sp, {emit_reg reg_tmp}\n` ++ ++let emit_mem_op op src ofs = ++ if is_immediate ofs then ++ ` {emit_string op} {emit_string src}, {emit_int ofs}(sp)\n` ++ else begin ++ ` li {emit_reg reg_tmp}, {emit_int ofs}\n`; ++ ` add {emit_reg reg_tmp}, sp, {emit_reg reg_tmp}\n`; ++ ` {emit_string op} {emit_string src}, 0({emit_reg reg_tmp})\n` ++ end ++ ++let emit_store src ofs = ++ emit_mem_op "sd" src ofs ++ ++let emit_load dst ofs = ++ emit_mem_op "ld" dst ofs ++ ++let reload_ra n = ++ emit_load "ra" (n - size_addr) ++ ++let store_ra n = ++ emit_store "ra" (n - size_addr) ++ ++let emit_store src ofs = ++ emit_store (reg_name src) ofs ++ ++let emit_load dst ofs = ++ emit_load (reg_name dst) ofs ++ ++let emit_float_load dst ofs = ++ emit_mem_op "fld" (reg_name dst) ofs ++ ++let emit_float_store src ofs = ++ emit_mem_op "fsd" (reg_name src) ofs ++ ++(* Record live pointers at call points *) ++ ++let record_frame_label ?label live 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; ++ record_frame_descr ~label:lbl ~frame_size:(frame_size()) ++ ~live_offset:!live_offset dbg; ++ lbl ++ ++let record_frame ?label live dbg = ++ let lbl = record_frame_label ?label live dbg in ++ `{emit_label lbl}:\n` ++ ++(* Record calls to the GC -- we've moved them out of the way *) ++ ++type gc_call = ++ { gc_lbl: label; (* Entry label *) ++ gc_return_lbl: label; (* Where to branch after GC *) ++ gc_frame_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`; ++ ` {emit_call "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 (Dbg_other 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`; ++ ` {emit_call "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" ++ | _ -> Misc.fatal_error "Emit.Intop" ++ ++let name_for_intop_imm = function ++ | Iadd -> "addi" ++ | Iand -> "andi" ++ | Ior -> "ori" ++ | Ixor -> "xori" ++ | Ilsl -> "slli" ++ | Ilsr -> "srli" ++ | Iasr -> "srai" ++ | _ -> Misc.fatal_error "Emit.Intop_imm" ++ ++let name_for_floatop1 = function ++ | Inegf -> "fneg.d" ++ | Iabsf -> "fabs.d" ++ | _ -> Misc.fatal_error "Emit.Iopf1" ++ ++let name_for_floatop2 = function ++ | Iaddf -> "fadd.d" ++ | Isubf -> "fsub.d" ++ | Imulf -> "fmul.d" ++ | Idivf -> "fdiv.d" ++ | _ -> Misc.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 = ++ emit_debug_info i.dbg; ++ match i.desc with ++ Lend -> () ++ | Lprologue -> ++ assert (!prologue_required); ++ let n = frame_size() in ++ emit_stack_adjustment (-n); ++ if !contains_calls then store_ra n ++ | 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 _} -> ++ ` fmv.d {emit_reg dst}, {emit_reg src}\n` ++ | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack s} -> ++ let ofs = slot_offset s (register_class dst) in ++ emit_store src ofs ++ | {loc = Reg _; typ = Float}, {loc = Stack s} -> ++ let ofs = slot_offset s (register_class dst) in ++ emit_float_store src ofs ++ | {loc = Stack s; typ = (Val | Int | Addr)}, {loc = Reg _} -> ++ let ofs = slot_offset s (register_class src) in ++ emit_load dst ofs ++ | {loc = Stack s; typ = Float}, {loc = Reg _} -> ++ let ofs = slot_offset s (register_class src) in ++ emit_float_load dst ofs ++ | {loc = Stack _}, {loc = Stack _} ++ | {loc = Unknown}, _ | _, {loc = Unknown} -> ++ Misc.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_tmp}\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 (Dbg_other i.dbg) ++ | Lop(Icall_imm {func; label_after = label}) -> ++ ` {emit_call func}\n`; ++ record_frame ~label i.live (Dbg_other i.dbg) ++ | Lop(Itailcall_ind {label_after = _}) -> ++ let n = frame_size() in ++ if !contains_calls then reload_ra n; ++ emit_stack_adjustment 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 reload_ra n; ++ emit_stack_adjustment n; ++ ` {emit_tail func}\n` ++ end ++ | Lop(Iextcall{func; alloc = true; label_after = label}) -> ++ ` la {emit_reg reg_t2}, {emit_symbol func}\n`; ++ ` {emit_call "caml_c_call"}\n`; ++ record_frame ~label i.live (Dbg_other i.dbg) ++ | Lop(Iextcall{func; alloc = false; label_after = _}) -> ++ ` {emit_call func}\n` ++ | Lop(Istackoffset n) -> ++ assert (n mod 16 = 0); ++ emit_stack_adjustment (-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 -> "lwu" ++ | Thirtytwo_signed -> "lw" ++ | Word_int | Word_val -> "ld" ++ | 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, _)) -> ++ (* ft0 is marked as destroyed for this operation *) ++ ` fcvt.s.d ft0, {emit_reg i.arg.(0)}\n`; ++ ` fsw ft0, {emit_int ofs}({emit_reg i.arg.(1)})\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 -> "sd" ++ | 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 {bytes; label_after_call_gc = label; dbginfo}) -> ++ let lbl_frame_lbl = record_frame_label ?label i.live (Dbg_alloc dbginfo) in ++ let lbl_after_alloc = new_label () in ++ let lbl_call_gc = new_label () in ++ let n = -bytes in ++ if is_immediate n then ++ ` addi {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, {emit_int n}\n` ++ else begin ++ ` li {emit_reg reg_tmp}, {emit_int n}\n`; ++ ` add {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, {emit_reg reg_tmp}\n` ++ end; ++ ` bltu {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_lim}, {emit_label lbl_call_gc}\n`; ++ `{emit_label lbl_after_alloc}:\n`; ++ ` addi {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, {emit_int size_addr}\n`; ++ call_gc_sites := ++ { gc_lbl = lbl_call_gc; ++ gc_return_lbl = lbl_after_alloc; ++ 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 _, _)) -> ++ Misc.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_tmp}, {emit_int n}\n`; ++ ` bleu {emit_reg i.arg.(0)}, {emit_reg reg_tmp}, {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) -> ++ ` fcvt.d.l {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` ++ | Lop(Iintoffloat) -> ++ ` fcvt.l.d {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, rtz\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` ++ | Lop (Iname_for_debugger _) -> ++ () ++ | Lreloadretaddr -> ++ let n = frame_size () in ++ reload_ra n ++ | Lreturn -> ++ let n = frame_size() in ++ emit_stack_adjustment 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 _ -> ++ Misc.fatal_error "Emit.emit_instr (Iinttest_imm _)" ++ | Ifloattest cmp -> ++ let branch = ++ match cmp with ++ | CFneq | CFnlt | CFngt | CFnle | CFnge -> "beqz" ++ | CFeq | CFlt | CFgt | CFle | CFge -> "bnez" ++ in ++ begin match cmp with ++ | CFeq | CFneq -> ` feq.d {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | CFlt | CFnlt -> ` flt.d {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | CFgt | CFngt -> ` flt.d {emit_reg reg_tmp}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` ++ | CFle | CFnle -> ` fle.d {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | CFge | CFnge -> ` fle.d {emit_reg reg_tmp}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` ++ end; ++ ` {emit_string branch} {emit_reg reg_tmp}, {emit_label lbl}\n` ++ | Ioddtest -> ++ ` andi {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, 1\n`; ++ ` bnez {emit_reg reg_tmp}, {emit_label lbl}\n` ++ | Ieventest -> ++ ` andi {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, 1\n`; ++ ` beqz {emit_reg reg_tmp}, {emit_label lbl}\n` ++ end ++ | Lcondbranch3(lbl0, lbl1, lbl2) -> ++ ` addi {emit_reg reg_tmp}, {emit_reg i.arg.(0)}, -1\n`; ++ begin match lbl0 with ++ | None -> () ++ | Some lbl -> ` bltz {emit_reg reg_tmp}, {emit_label lbl}\n` ++ end; ++ begin match lbl1 with ++ | None -> () ++ | Some lbl -> ` beqz {emit_reg reg_tmp}, {emit_label lbl}\n` ++ end; ++ begin match lbl2 with ++ | None -> () ++ | Some lbl -> ` bgtz {emit_reg reg_tmp}, {emit_label lbl}\n` ++ end ++ | Lswitch jumptbl -> ++ (* t0 is marked as destroyed for this operation *) ++ let lbl = new_label() in ++ ` la {emit_reg reg_tmp}, {emit_label lbl}\n`; ++ ` slli t0, {emit_reg i.arg.(0)}, 2\n`; ++ ` add {emit_reg reg_tmp}, {emit_reg reg_tmp}, t0\n`; ++ ` jr {emit_reg reg_tmp}\n`; ++ `{emit_label lbl}:\n`; ++ for i = 0 to Array.length jumptbl - 1 do ++ ` j {emit_label jumptbl.(i)}\n` ++ done ++ | Lentertrap -> ++ () ++ | Ladjust_trap_depth { delta_traps } -> ++ (* each trap occupes 16 bytes on the stack *) ++ let delta = 16 * delta_traps in ++ stack_offset := !stack_offset + delta ++ | Lpushtrap {lbl_handler} -> ++ ` la {emit_reg reg_tmp}, {emit_label lbl_handler}\n`; ++ ` addi sp, sp, -16\n`; ++ stack_offset := !stack_offset + 16; ++ emit_store reg_tmp size_addr; ++ emit_store reg_trap 0; ++ ` mv {emit_reg reg_trap}, sp\n` ++ | Lpoptrap -> ++ emit_load reg_trap 0; ++ ` addi sp, sp, 16\n`; ++ stack_offset := !stack_offset - 16 ++ | Lraise k -> ++ begin match k with ++ | Lambda.Raise_regular -> ++ let offset = Domainstate.(idx_of_field Domain_backtrace_pos) * 8 in ++ ` sd zero, {emit_int offset}({emit_reg reg_domain_state_ptr})\n`; ++ ` {emit_call "caml_raise_exn"}\n`; ++ record_frame Reg.Set.empty (Dbg_raise i.dbg) ++ | Lambda.Raise_reraise -> ++ ` {emit_call "caml_raise_exn"}\n`; ++ record_frame Reg.Set.empty (Dbg_raise i.dbg) ++ | Lambda.Raise_notrace -> ++ ` mv sp, {emit_reg reg_trap}\n`; ++ emit_load reg_tmp size_addr; ++ emit_load reg_trap 0; ++ ` addi sp, sp, 16\n`; ++ ` jr {emit_reg reg_tmp}\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 := fundecl.fun_tailrec_entry_point_label; ++ stack_offset := 0; ++ call_gc_sites := []; ++ bound_error_sites := []; ++ for i = 0 to Proc.num_register_classes - 1 do ++ num_stack_slots.(i) <- fundecl.fun_num_stack_slots.(i); ++ done; ++ prologue_required := fundecl.fun_prologue_required; ++ contains_calls := fundecl.fun_contains_calls; ++ 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`; ++ emit_debug_info fundecl.fun_dbg; ++ 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`; ++ emit_float64_directive ".quad" 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 -> ++ ` .quad {emit_nativeint n}\n` ++ | Csingle f -> ++ emit_float32_directive ".long" (Int32.bits_of_float f) ++ | Cdouble f -> ++ emit_float64_directive ".quad" (Int64.bits_of_float f) ++ | Csymbol_address s -> ++ ` .quad {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() = ++ if !Clflags.dlcode || !Clflags.pic_code then ` .option pic\n`; ++ ` .file \"\"\n`; (* PR#7073 *) ++ reset_debug_info (); ++ (* 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; ++ ` .quad 0\n`; (* PR#6329 *) ++ `{emit_symbol lbl_end}:\n`; ++ ` .quad 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 -> ` .quad {emit_label l}\n`); ++ efa_data_label = (fun l -> ` .quad {emit_label l}\n`); ++ efa_8 = (fun n -> ` .byte {emit_int n}\n`); ++ efa_16 = (fun n -> ` .short {emit_int n}\n`); ++ efa_32 = (fun n -> ` .long {emit_int32 n}\n`); ++ efa_word = (fun n -> ` .quad {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..70909cd83 +--- /dev/null ++++ b/asmcomp/riscv/proc.ml +@@ -0,0 +1,334 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* 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 ++ a0-a7 0-7 arguments/results ++ s2-s9 8-15 arguments/results (preserved by C) ++ t2-t6 16-20 temporary ++ t0-t1 21-22 temporary (used by code generator) ++ s0 23 domain 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 ++ ++ Additional notes ++ ---------------- ++ ++ - t0-t1 are used by the assembler and code generator, so ++ not available for register allocation. ++ ++ - t0-t6 may be used by PLT stubs, so should not be used to pass ++ arguments and may be clobbered by [Ialloc] in the presence of dynamic ++ linking. ++*) ++ ++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 = [| 22; 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 ++ | _ -> ++ 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 a0 *) ++ ++let loc_exn_bucket = phys_reg 0 ++ ++(* Volatile registers: none *) ++ ++let regs_are_volatile _ = false ++ ++(* Registers destroyed by operations *) ++ ++let destroyed_at_c_call = ++ (* s0-s11 and fs0-fs11 are callee-save *) ++ Array.of_list(List.map phys_reg ++ [0; 1; 2; 3; 4; 5; 6; 7; 16; 17; 18; 19; 20; 21; ++ 100; 101; 102; 103; 104; 105; 106; 107; 110; 111; 112; 113; 114; 115; 116; ++ 117; 128; 129; 130; 131]) ++ ++let destroyed_at_alloc = ++ (* t0-t3 are used for PLT stubs *) ++ if !Clflags.dlcode then Array.map phys_reg [|16; 17; 18; 19; 20; 21|] ++ else [| |] ++ ++let destroyed_at_oper = function ++ | Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}) -> all_phys_regs ++ | Iop(Iextcall{alloc = false; _}) -> destroyed_at_c_call ++ | Iop(Ialloc _) -> destroyed_at_alloc ++ | Iop(Istore(Single, _, _)) -> [| phys_reg 100 |] ++ | Iswitch _ -> [| phys_reg 21 |] ++ | _ -> [||] ++ ++let destroyed_at_raise = all_phys_regs ++ ++let destroyed_at_reloadretaddr = [| |] ++ ++(* Maximal register pressure *) ++ ++let safe_register_pressure = function ++ | Iextcall _ -> 15 ++ | _ -> 22 ++ ++let max_register_pressure = function ++ | Iextcall _ -> [| 15; 18 |] ++ | _ -> [| 22; 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 frame_required fd = ++ fd.fun_contains_calls ++ || fd.fun_num_stack_slots.(0) > 0 ++ || fd.fun_num_stack_slots.(1) > 0 ++ ++let prologue_required fd = ++ frame_required fd ++ ++(* See ++ https://github.com/riscv/riscv-elf-psabi-doc/blob/master/riscv-elf.md *) ++ ++let int_dwarf_reg_numbers = ++ [| 10; 11; 12; 13; 14; 15; 16; 17; ++ 18; 19; 20; 21; 22; 23; 24; 25; ++ 7; 28; 29; 30; 31; ++ 5; 6; ++ 8; 9; 26; 27; ++ |] ++ ++let float_dwarf_reg_numbers = ++ [| 32; 33; 34; 35; 36; 37; 38; 39; ++ 40; 41; ++ 42; 43; 44; 45; 46; 47; 48; 49; ++ 50; 51; 52; 53; 54; 55; 56; 57; ++ 58; 59; ++ 60; 61; 62; 63; ++ |] ++ ++let dwarf_register_numbers ~reg_class = ++ match reg_class with ++ | 0 -> int_dwarf_reg_numbers ++ | 1 -> float_dwarf_reg_numbers ++ | _ -> Misc.fatal_errorf "Bad register class %d" reg_class ++ ++let stack_ptr_dwarf_register_number = 2 ++ ++(* 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..be18cbd7f +--- /dev/null ++++ b/asmcomp/riscv/reload.ml +@@ -0,0 +1,19 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* 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..e56b723c5 +--- /dev/null ++++ b/asmcomp/riscv/scheduling.ml +@@ -0,0 +1,22 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* Instruction scheduling for the RISC-V *) ++ ++open! Schedgen (* 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..87d3355de +--- /dev/null ++++ b/asmcomp/riscv/selection.ml +@@ -0,0 +1,75 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* 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 = is_immediate n ++ ++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, _)], _)], dbg) ++ when self#is_immediate n -> ++ (Iindexed n, Cop(Caddi, [arg1; arg2], dbg)) ++ | arg -> ++ (Iindexed 0, arg) ++ ++method! select_operation op args dbg = ++ match (op, args) with ++ (* 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) ++ (* RISC-V does not support immediate operands for multiply/multiply high *) ++ | (Cmuli, _) -> (Iintop Imul, args) ++ | (Cmulhi, _) -> (Iintop Imulh, args) ++ | _ -> ++ super#select_operation op args dbg ++ ++(* 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, 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/configure b/configure +index 32cb19b3b..12e08bba2 100755 +--- a/configure ++++ b/configure +@@ -13578,6 +13578,8 @@ if test x"$enable_shared" != "xno"; then : + natdynlink=true ;; #( + aarch64-*-freebsd*) : + natdynlink=true ;; #( ++ riscv*-*-linux*) : ++ natdynlink=true ;; #( + *) : + ;; + esac +@@ -13718,7 +13720,9 @@ fi; system=elf ;; #( + aarch64-*-freebsd*) : + arch=arm64; system=freebsd ;; #( + x86_64-*-cygwin*) : +- arch=amd64; system=cygwin ++ arch=amd64; system=cygwin ;; #( ++ riscv64-*-linux*) : ++ arch=riscv; model=riscv64; system=linux + ;; #( + *) : + ;; +@@ -13952,7 +13956,7 @@ esac ;; #( + *,dragonfly) : + default_as="${toolpref}as" + default_aspp="${toolpref}cc -c" ;; #( +- amd64,*|arm,*|arm64,*|i386,*) : ++ amd64,*|arm,*|arm64,*|i386,*|riscv,*) : + case $ocaml_cv_cc_vendor in #( + clang-*) : + default_as="${toolpref}clang -c -Wno-trigraphs" +diff --git a/configure.ac b/configure.ac +index 4c9358897..b7e0731e0 100644 +--- a/configure.ac ++++ b/configure.ac +@@ -868,7 +868,8 @@ AS_IF([test x"$enable_shared" != "xno"], + [arm*-*-freebsd*], [natdynlink=true], + [earm*-*-netbsd*], [natdynlink=true], + [aarch64-*-linux*], [natdynlink=true], +- [aarch64-*-freebsd*], [natdynlink=true])]) ++ [aarch64-*-freebsd*], [natdynlink=true], ++ [riscv*-*-linux*], [natdynlink=true])]) + + # Try to work around the Skylake/Kaby Lake processor bug. + AS_CASE(["$CC,$host"], +@@ -961,7 +962,9 @@ AS_CASE([$host], + [aarch64-*-freebsd*], + [arch=arm64; system=freebsd], + [x86_64-*-cygwin*], +- [arch=amd64; system=cygwin] ++ [arch=amd64; system=cygwin], ++ [riscv64-*-linux*], ++ [arch=riscv; model=riscv64; system=linux] + ) + + AS_IF([test x"$enable_native_compiler" = "xno"], +@@ -1065,7 +1068,7 @@ AS_CASE(["$arch,$system"], + [*,dragonfly], + [default_as="${toolpref}as" + default_aspp="${toolpref}cc -c"], +- [amd64,*|arm,*|arm64,*|i386,*], ++ [amd64,*|arm,*|arm64,*|i386,*|riscv,*], + [AS_CASE([$ocaml_cv_cc_vendor], + [clang-*], [default_as="${toolpref}clang -c -Wno-trigraphs" + default_aspp="${toolpref}clang -c -Wno-trigraphs"], +diff --git a/runtime/caml/stack.h b/runtime/caml/stack.h +index df0424683..6b7df0e67 100644 +--- a/runtime/caml/stack.h ++++ b/runtime/caml/stack.h +@@ -70,6 +70,11 @@ + #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) + #endif + ++#ifdef TARGET_riscv ++#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/runtime/riscv.S b/runtime/riscv.S +new file mode 100644 +index 000000000..48e690e44 +--- /dev/null ++++ b/runtime/riscv.S +@@ -0,0 +1,423 @@ ++/**************************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* Nicolas Ojeda Bar */ ++/* */ ++/* Copyright 2016 Institut National de Recherche en Informatique et */ ++/* en Automatique. */ ++/* */ ++/* All rights reserved. This file is distributed under the terms of */ ++/* the GNU Lesser General Public License version 2.1, with the */ ++/* special exception on linking described in the file LICENSE. */ ++/* */ ++/**************************************************************************/ ++ ++/* Asm part of the runtime system, RISC-V processor, 64-bit mode */ ++/* Must be preprocessed by cpp */ ++ ++#define ARG_DOMAIN_STATE_PTR t0 ++#define DOMAIN_STATE_PTR s0 ++#define TRAP_PTR s1 ++#define ALLOC_PTR s10 ++#define ALLOC_LIMIT s11 ++#define TMP t1 ++#define ARG t2 ++ ++#define STORE sd ++#define LOAD ld ++ ++ .set domain_curr_field, 0 ++#define DOMAIN_STATE(c_type, name) \ ++ .equ domain_field_caml_##name, domain_curr_field ; \ ++ .set domain_curr_field, domain_curr_field + 1 ++#include "../runtime/caml/domain_state.tbl" ++#undef DOMAIN_STATE ++ ++#define Caml_state(var) (8*domain_field_caml_##var)(s0) ++ ++#define FUNCTION(name) \ ++ .align 2; \ ++ .globl name; \ ++ .type name, @function; \ ++name: ++ ++#if defined(__PIC__) ++ .option pic ++#define PLT(r) r@plt ++#else ++ .option nopic ++#define PLT(r) r ++#endif ++ ++ .section .text ++/* Invoke the garbage collector. */ ++ ++ .globl caml_system__code_begin ++caml_system__code_begin: ++ ++FUNCTION(caml_call_gc) ++.Lcaml_call_gc: ++ /* Record return address */ ++ STORE ra, Caml_state(last_return_address) ++ /* Record lowest stack address */ ++ STORE sp, Caml_state(bottom_of_stack) ++ /* 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 ++ 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 TMP, sp, 0x10 ++ STORE TMP, Caml_state(gc_regs) ++ /* Save current allocation pointer for debugging purposes */ ++ STORE ALLOC_PTR, Caml_state(young_ptr) ++ /* Save trap pointer in case an exception is raised during GC */ ++ STORE TRAP_PTR, Caml_state(exception_pointer) ++ /* Call the garbage collector */ ++ call PLT(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_state(young_ptr) ++ LOAD ALLOC_LIMIT, Caml_state(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 */ ++ ++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_state(last_return_address) ++ STORE sp, Caml_state(bottom_of_stack) ++ /* Make the exception handler alloc ptr available to the C code */ ++ STORE ALLOC_PTR, Caml_state(young_ptr) ++ STORE TRAP_PTR, Caml_state(exception_pointer) ++ /* Call the function */ ++ jalr ARG ++ /* Reload alloc ptr and alloc limit */ ++ LOAD ALLOC_PTR, Caml_state(young_ptr) ++ LOAD ALLOC_LIMIT, Caml_state(young_limit) ++ /* Return */ ++ jr s2 ++ .size caml_c_call, .-caml_c_call ++ ++/* Raise an exception from OCaml */ ++FUNCTION(caml_raise_exn) ++ /* Test if backtrace is active */ ++ LOAD TMP, Caml_state(backtrace_active) ++ bnez TMP, 2f ++1: /* Cut stack at current trap handler */ ++ mv sp, TRAP_PTR ++ /* Pop previous handler and jump to it */ ++ LOAD TMP, 8(sp) ++ LOAD TRAP_PTR, 0(sp) ++ addi sp, sp, 16 ++ jr TMP ++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 PLT(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 */ ++ ++FUNCTION(caml_raise_exception) ++ mv DOMAIN_STATE_PTR, a0 ++ mv a0, a1 ++ LOAD TRAP_PTR, Caml_state(exception_pointer) ++ LOAD ALLOC_PTR, Caml_state(young_ptr) ++ LOAD ALLOC_LIMIT, Caml_state(young_limit) ++ LOAD TMP, Caml_state(backtrace_active) ++ bnez TMP, 2f ++1: /* Cut stack at current trap handler */ ++ mv sp, TRAP_PTR ++ LOAD TMP, 8(sp) ++ LOAD TRAP_PTR, 0(sp) ++ addi sp, sp, 16 ++ jr TMP ++2: /* Preserve exception bucket in callee-save register s2 */ ++ mv s2, a0 ++ LOAD a1, Caml_state(last_return_address) ++ LOAD a2, Caml_state(bottom_of_stack) ++ mv a3, TRAP_PTR ++ call PLT(caml_stash_backtrace) ++ mv a0, s2 ++ j 1b ++ .size caml_raise_exception, .-caml_raise_exception ++ ++/* Start the OCaml program */ ++ ++FUNCTION(caml_start_program) ++ mv ARG_DOMAIN_STATE_PTR, a0 ++ 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 ++ /* Load domain state pointer from argument */ ++ mv DOMAIN_STATE_PTR, ARG_DOMAIN_STATE_PTR ++ /* Setup a callback link on the stack */ ++ LOAD TMP, Caml_state(bottom_of_stack) ++ STORE TMP, 0(sp) ++ LOAD TMP, Caml_state(last_return_address) ++ STORE TMP, 8(sp) ++ LOAD TMP, Caml_state(gc_regs) ++ STORE TMP, 16(sp) ++ /* set up a trap frame */ ++ addi sp, sp, -16 ++ LOAD TMP, Caml_state(exception_pointer) ++ STORE TMP, 0(sp) ++ lla TMP, .Ltrap_handler ++ STORE TMP, 8(sp) ++ mv TRAP_PTR, sp ++ LOAD ALLOC_PTR, Caml_state(young_ptr) ++ LOAD ALLOC_LIMIT, Caml_state(young_limit) ++ STORE x0, Caml_state(last_return_address) ++ jalr ARG ++.Lcaml_retaddr: /* pop trap frame, restoring caml_exception_pointer */ ++ LOAD TMP, 0(sp) ++ STORE TMP, Caml_state(exception_pointer) ++ addi sp, sp, 16 ++.Lreturn_result: /* pop callback link, restoring global variables */ ++ LOAD TMP, 0(sp) ++ STORE TMP, Caml_state(bottom_of_stack) ++ LOAD TMP, 8(sp) ++ STORE TMP, Caml_state(last_return_address) ++ LOAD TMP, 16(sp) ++ STORE TMP, Caml_state(gc_regs) ++ addi sp, sp, 32 ++ /* Update allocation pointer */ ++ STORE ALLOC_PTR, Caml_state(young_ptr) ++ /* 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 ++ .type .Lcaml_retaddr, @function ++ .size .Lcaml_retaddr, .-.Lcaml_retaddr ++ .size caml_start_program, .-caml_start_program ++ ++ .align 2 ++.Ltrap_handler: ++ STORE TRAP_PTR, Caml_state(exception_pointer) ++ ori a0, a0, 2 ++ j .Lreturn_result ++ .type .Ltrap_handler, @function ++ .size .Ltrap_handler, .-.Ltrap_handler ++ ++/* Callback from C to OCaml */ ++ ++FUNCTION(caml_callback_asm) ++ /* Initial shuffling of arguments */ ++ /* a0 = Caml_state, a1 = closure, (a2) = args */ ++ mv ARG_DOMAIN_STATE_PTR, a0 ++ LOAD a0, 0(a2) /* a0 = first arg */ ++ /* a1 = closure environment */ ++ LOAD ARG, 0(a1) /* code pointer */ ++ j .Ljump_to_caml ++ .size caml_callback_asm, .-caml_callback_asm ++ ++FUNCTION(caml_callback2_asm) ++ /* Initial shuffling of arguments */ ++ /* a0 = Caml_state, a1 = closure, (a2) = args */ ++ mv ARG_DOMAIN_STATE_PTR, a0 ++ mv TMP, a1 ++ LOAD a0, 0(a2) ++ LOAD a1, 8(a2) ++ mv a2, TMP ++ la ARG, caml_apply2 ++ j .Ljump_to_caml ++ .size caml_callback2_asm, .-caml_callback2_asm ++ ++FUNCTION(caml_callback3_asm) ++ /* Initial shuffling of arguments */ ++ /* a0 = Caml_state, a1 = closure, (a2) = args */ ++ mv ARG_DOMAIN_STATE_PTR, a0 ++ mv a3, a1 ++ LOAD a0, 0(a2) ++ LOAD a1, 8(a2) ++ LOAD a2, 16(a2) ++ la ARG, caml_apply3 ++ j .Ljump_to_caml ++ .size caml_callback3_asm, .-caml_callback3_asm ++ ++FUNCTION(caml_ml_array_bound_error) ++ /* Load address of [caml_array_bound_error] in ARG */ ++ la ARG, caml_array_bound_error ++ /* Call that function */ ++ tail caml_c_call ++ .size caml_ml_array_bound_error, .-caml_ml_array_bound_error ++ ++ .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/testsuite/tools/asmgen_riscv.S b/testsuite/tools/asmgen_riscv.S +new file mode 100644 +index 000000000..efb30a80f +--- /dev/null ++++ b/testsuite/tools/asmgen_riscv.S +@@ -0,0 +1,89 @@ ++/**************************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* Nicolas Ojeda Bar */ ++/* */ ++/* Copyright 2019 Institut National de Recherche en Informatique et */ ++/* en Automatique. */ ++/* */ ++/* All rights reserved. This file is distributed under the terms of */ ++/* the GNU Lesser General Public License version 2.1, with the */ ++/* special exception on linking described in the file LICENSE. */ ++/* */ ++/**************************************************************************/ ++ ++#define STORE sd ++#define LOAD ld ++ ++ .globl call_gen_code ++ .align 2 ++call_gen_code: ++ /* Set up stack frame and save callee-save registers */ ++ ADDI sp, sp, -208 ++ STORE ra, 192(sp) ++ STORE s0, 0(sp) ++ STORE s1, 8(sp) ++ STORE s2, 16(sp) ++ STORE s3, 24(sp) ++ STORE s4, 32(sp) ++ STORE s5, 40(sp) ++ STORE s6, 48(sp) ++ STORE s7, 56(sp) ++ STORE s8, 64(sp) ++ STORE s9, 72(sp) ++ STORE s10, 80(sp) ++ STORE s11, 88(sp) ++ fsd fs0, 96(sp) ++ fsd fs1, 104(sp) ++ fsd fs2, 112(sp) ++ fsd fs3, 120(sp) ++ fsd fs4, 128(sp) ++ fsd fs5, 136(sp) ++ fsd fs6, 144(sp) ++ fsd fs7, 152(sp) ++ fsd fs8, 160(sp) ++ fsd fs9, 168(sp) ++ fsd fs10, 176(sp) ++ fsd fs11, 184(sp) ++ /* Shuffle arguments */ ++ mv t0, a0 ++ mv a0, a1 ++ mv a1, a2 ++ mv a2, a3 ++ mv a3, a4 ++ /* Call generated asm */ ++ jalr t0 ++ /* Reload callee-save registers and return address */ ++ LOAD ra, 192(sp) ++ LOAD s0, 0(sp) ++ LOAD s1, 8(sp) ++ LOAD s2, 16(sp) ++ LOAD s3, 24(sp) ++ LOAD s4, 32(sp) ++ LOAD s5, 40(sp) ++ LOAD s6, 48(sp) ++ LOAD s7, 56(sp) ++ LOAD s8, 64(sp) ++ LOAD s9, 72(sp) ++ LOAD s10, 80(sp) ++ LOAD s11, 88(sp) ++ fld fs0, 96(sp) ++ fld fs1, 104(sp) ++ fld fs2, 112(sp) ++ fld fs3, 120(sp) ++ fld fs4, 128(sp) ++ fld fs5, 136(sp) ++ fld fs6, 144(sp) ++ fld fs7, 152(sp) ++ fld fs8, 160(sp) ++ fld fs9, 168(sp) ++ fld fs10, 176(sp) ++ fld fs11, 184(sp) ++ addi sp, sp, 208 ++ ret ++ ++ .globl caml_c_call ++ .align 2 ++caml_c_call: ++ jr t2 +-- +2.24.1 + diff --git a/0005-Merge-pull-request-9457-from-dra27-fix-mod_use.patch b/0005-Merge-pull-request-9457-from-dra27-fix-mod_use.patch deleted file mode 100644 index e2c4d9b..0000000 --- a/0005-Merge-pull-request-9457-from-dra27-fix-mod_use.patch +++ /dev/null @@ -1,174 +0,0 @@ -From 2e40ed7452896a5ad043ca1297112d2a5bf6189b Mon Sep 17 00:00:00 2001 -From: David Allsopp -Date: Mon, 20 Apr 2020 16:13:26 +0100 -Subject: [PATCH 5/7] Merge pull request #9457 from dra27/fix-mod_use - -Fix #mod_use in toplevel - -(cherry picked from commit f4dc3003d579e45f6ddeb6ffceb4c283a9e15bc7) ---- - Changes | 2 +- - testsuite/tests/tool-toplevel/mod.ml | 1 + - testsuite/tests/tool-toplevel/mod_use.ml | 9 +++++++++ - toplevel/opttoploop.ml | 19 +++++++++++-------- - toplevel/toploop.ml | 19 +++++++++++-------- - 5 files changed, 33 insertions(+), 17 deletions(-) - create mode 100644 testsuite/tests/tool-toplevel/mod.ml - create mode 100644 testsuite/tests/tool-toplevel/mod_use.ml - -diff --git a/Changes b/Changes -index f16158f12..a65573604 100644 ---- a/Changes -+++ b/Changes -@@ -164,7 +164,7 @@ Working version - points to the grammar. - (Andreas Abel, review by Xavier Leroy) - --- #9283: add a new toplevel directive `#use_output ""` to -+- #9283, #9455, #9457: add a new toplevel directive `#use_output ""` to - run a command and evaluate its output. - (Jérémie Dimino, review by David Allsopp) - -diff --git a/testsuite/tests/tool-toplevel/mod.ml b/testsuite/tests/tool-toplevel/mod.ml -new file mode 100644 -index 000000000..cd298427b ---- /dev/null -+++ b/testsuite/tests/tool-toplevel/mod.ml -@@ -0,0 +1 @@ -+let answer = 42 -diff --git a/testsuite/tests/tool-toplevel/mod_use.ml b/testsuite/tests/tool-toplevel/mod_use.ml -new file mode 100644 -index 000000000..e068ffc3a ---- /dev/null -+++ b/testsuite/tests/tool-toplevel/mod_use.ml -@@ -0,0 +1,9 @@ -+(* TEST -+ files = "mod.ml" -+ * expect -+*) -+ -+#mod_use "mod.ml" -+[%%expect {| -+module Mod : sig val answer : int end -+|}];; -diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml -index cd4210bbe..ad9a2569e 100644 ---- a/toplevel/opttoploop.ml -+++ b/toplevel/opttoploop.ml -@@ -449,7 +449,7 @@ let preprocess_phrase ppf phr = - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr - --let use_channel ppf wrap_mod ic name filename = -+let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in - Location.init lb filename; - (* Skip initial #! line if any *) -@@ -461,7 +461,7 @@ let use_channel ppf wrap_mod ic name filename = - (fun ph -> - let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit) -- (if wrap_mod then -+ (if wrap_in_module then - parse_mod_use_file name lb - else - !parse_use_file lb); -@@ -485,27 +485,30 @@ let use_output ppf command = - | 0 -> - let ic = open_in_bin fn in - Misc.try_finally ~always:(fun () -> close_in ic) -- (fun () -> use_channel ppf false ic "" "(command-output)") -+ (fun () -> -+ use_channel ppf ~wrap_in_module:false ic "" "(command-output)") - | n -> - fprintf ppf "Command exited with code %d.@." n; - false) - --let use_file ppf wrap_mode name = -+let use_file ppf ~wrap_in_module name = - match name with - | "" -> -- use_channel ppf wrap_mode stdin name "(stdin)" -+ use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally ~always:(fun () -> close_in ic) -- (fun () -> use_channel ppf false ic name filename) -+ (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false - --let mod_use_file ppf name = use_file ppf true name --let use_file ppf name = use_file ppf false name -+let mod_use_file ppf name = -+ use_file ppf ~wrap_in_module:true name -+let use_file ppf name = -+ use_file ppf ~wrap_in_module:false name - - let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) -diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml -index 02f629f9d..09e550796 100644 ---- a/toplevel/toploop.ml -+++ b/toplevel/toploop.ml -@@ -394,7 +394,7 @@ let preprocess_phrase ppf phr = - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr - --let use_channel ppf wrap_mod ic name filename = -+let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in - Warnings.reset_fatal (); - Location.init lb filename; -@@ -408,7 +408,7 @@ let use_channel ppf wrap_mod ic name filename = - (fun ph -> - let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit) -- (if wrap_mod then -+ (if wrap_in_module then - parse_mod_use_file name lb - else - !parse_use_file lb); -@@ -431,27 +431,30 @@ let use_output ppf command = - | 0 -> - let ic = open_in_bin fn in - Misc.try_finally ~always:(fun () -> close_in ic) -- (fun () -> use_channel ppf false ic "" "(command-output)") -+ (fun () -> -+ use_channel ppf ~wrap_in_module:false ic "" "(command-output)") - | n -> - fprintf ppf "Command exited with code %d.@." n; - false) - --let use_file ppf wrap_mode name = -+let use_file ppf ~wrap_in_module name = - match name with - | "" -> -- use_channel ppf wrap_mode stdin name "(stdin)" -+ use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally ~always:(fun () -> close_in ic) -- (fun () -> use_channel ppf false ic name filename) -+ (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false - --let mod_use_file ppf name = use_file ppf true name --let use_file ppf name = use_file ppf false name -+let mod_use_file ppf name = -+ use_file ppf ~wrap_in_module:true name -+let use_file ppf name = -+ use_file ppf ~wrap_in_module:false name - - let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) --- -2.24.1 - diff --git a/0006-Merge-pull-request-9463-from-lthls-fix_int64_cmm_typ.patch b/0006-Merge-pull-request-9463-from-lthls-fix_int64_cmm_typ.patch deleted file mode 100644 index 96e74b2..0000000 --- a/0006-Merge-pull-request-9463-from-lthls-fix_int64_cmm_typ.patch +++ /dev/null @@ -1,134 +0,0 @@ -From 13bec130864d682032f3b3086764487c26076093 Mon Sep 17 00:00:00 2001 -From: Gabriel Scherer -Date: Mon, 20 Apr 2020 11:34:15 +0200 -Subject: [PATCH 6/7] Merge pull request #9463 from lthls/fix_int64_cmm_typ - -Fix Cmm type of unboxed integers in Clet_mut - -(cherry picked from commit 702e34fbe56f6f03db086efe42148395c5e395ff) ---- - Changes | 6 ++- - asmcomp/cmmgen.ml | 15 ++++---- - testsuite/tests/lib-int64/issue9460.ml | 37 +++++++++++++++++++ - testsuite/tests/lib-int64/issue9460.reference | 1 + - 4 files changed, 49 insertions(+), 10 deletions(-) - create mode 100644 testsuite/tests/lib-int64/issue9460.ml - create mode 100644 testsuite/tests/lib-int64/issue9460.reference - -diff --git a/Changes b/Changes -index a65573604..5f92e00c1 100644 ---- a/Changes -+++ b/Changes -@@ -66,8 +66,10 @@ Working version - - #9280: Micro-optimise allocations on amd64 to save a register. - (Stephen Dolan, review by Xavier Leroy) - --- #9316: Use typing information from Clambda for mutable Cmm variables. -- (Stephen Dolan, review by Vincent Laviron, Guillaume Bury and Xavier Leroy) -+- #9316, #9443, #9463: Use typing information from Clambda -+ for mutable Cmm variables. -+ (Stephen Dolan, review by Vincent Laviron, Guillaume Bury, Xavier Leroy, -+ and Gabriel Scherer; temporary bug report by Richard Jones) - - - #9426: build the Mingw ports with higher levels of GCC optimization - (Xavier Leroy, review by Sébastien Hinderer) -diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml -index 6e1c924dc..ec9697177 100644 ---- a/asmcomp/cmmgen.ml -+++ b/asmcomp/cmmgen.ml -@@ -247,6 +247,11 @@ let box_int dbg bi arg = - - (* Boxed numbers *) - -+let typ_of_boxed_number = function -+ | Boxed_float _ -> Cmm.typ_float -+ | Boxed_integer (Pint64, _) when size_int = 4 -> [|Int;Int|] -+ | Boxed_integer _ -> Cmm.typ_int -+ - let equal_unboxed_integer ui1 ui2 = - match ui1, ui2 with - | Pnativeint, Pnativeint -> true -@@ -687,11 +692,6 @@ and transl_catch env nfail ids body handler dbg = - in - let env_body = add_notify_catch nfail report env in - let body = transl env_body body in -- let typ_of_bn = function -- | Boxed_float _ -> Cmm.typ_float -- | Boxed_integer (Pint64, _) when size_int = 4 -> [|Int;Int|] -- | Boxed_integer _ -> Cmm.typ_int -- in - let new_env, rewrite, ids = - List.fold_right - (fun (id, _kind, u) (env, rewrite, ids) -> -@@ -704,7 +704,7 @@ and transl_catch env nfail ids body handler dbg = - let unboxed_id = V.create_local (VP.name id) in - add_unboxed_id (VP.var id) unboxed_id bn env, - (unbox_number Debuginfo.none bn) :: rewrite, -- (VP.create unboxed_id, typ_of_bn bn) :: ids -+ (VP.create unboxed_id, typ_of_boxed_number bn) :: ids - ) - ids (env, [], []) - in -@@ -1165,8 +1165,7 @@ and transl_let env str kind id exp body = - transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body in - begin match str, boxed_number with - | Immutable, _ -> Clet (v, cexp, body) -- | Mutable, Boxed_float _ -> Clet_mut (v, typ_float, cexp, body) -- | Mutable, Boxed_integer _ -> Clet_mut (v, typ_int, cexp, body) -+ | Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body) - end - - and make_catch ncatch body handler dbg = match body with -diff --git a/testsuite/tests/lib-int64/issue9460.ml b/testsuite/tests/lib-int64/issue9460.ml -new file mode 100644 -index 000000000..aacbe6189 ---- /dev/null -+++ b/testsuite/tests/lib-int64/issue9460.ml -@@ -0,0 +1,37 @@ -+(* TEST -+*) -+ -+(* See https://github.com/ocaml/ocaml/issues/9460 -+ This test comes from Richard Jones -+ at -+ https://github.com/libguestfs/libnbd/blob/0475bfe04a527051c0a37af59a733c4c8554e427/ocaml/tests/test_400_pread.ml#L21-L36 -+*) -+let test_result = -+ let b = Bytes.create 16 in -+ for i = 0 to 16/8-1 do -+ let i64 = ref (Int64.of_int (i*8)) in -+ for j = 0 to 7 do -+ let c = Int64.shift_right_logical !i64 56 in -+ let c = Int64.to_int c in -+ let c = Char.chr c in -+ Bytes.unsafe_set b (i*8+j) c; -+ i64 := Int64.shift_left !i64 8 -+ done -+ done; -+ (Bytes.to_string b) ;; -+ -+let expected = -+ "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\008" -+ -+let () = -+ assert (test_result = expected) -+ -+(* Reproduction case by Jeremy Yallop in -+ https://github.com/ocaml/ocaml/pull/9463#issuecomment-615831765 -+*) -+let () = -+ let x = ref Int64.max_int in -+ assert (!x = Int64.max_int) -+ -+let () = -+ print_endline "OK" -diff --git a/testsuite/tests/lib-int64/issue9460.reference b/testsuite/tests/lib-int64/issue9460.reference -new file mode 100644 -index 000000000..d86bac9de ---- /dev/null -+++ b/testsuite/tests/lib-int64/issue9460.reference -@@ -0,0 +1 @@ -+OK --- -2.24.1 - diff --git a/0006-Support-FP-reg-int-reg-moves.patch b/0006-Support-FP-reg-int-reg-moves.patch new file mode 100644 index 0000000..1a0f343 --- /dev/null +++ b/0006-Support-FP-reg-int-reg-moves.patch @@ -0,0 +1,34 @@ +From d26a313ae92bb515b04865b6a71a63701dd1fe41 Mon Sep 17 00:00:00 2001 +From: Xavier Leroy +Date: Thu, 30 Apr 2020 16:18:06 +0200 +Subject: [PATCH 6/7] Support FP reg -> int reg moves + +Using instruction fmv.x.d. + +This is necessary to implement the ELF psABI calling conventions, +whereas some FP arguments may have to be passed in integer registers. + +(cherry picked from commit 16794b940555315c723411077a2902fc85a33c45) +--- + asmcomp/riscv/emit.mlp | 4 +++- + 1 file changed, 3 insertions(+), 1 deletion(-) + +diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp +index dc652de42..dbfdc2d40 100644 +--- a/asmcomp/riscv/emit.mlp ++++ b/asmcomp/riscv/emit.mlp +@@ -283,8 +283,10 @@ let emit_instr i = + 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 _} -> ++ | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> + ` fmv.d {emit_reg dst}, {emit_reg src}\n` ++ | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Val | Int | Addr)} -> ++ ` fmv.x.d {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack s} -> + let ofs = slot_offset s (register_class dst) in + emit_store src ofs +-- +2.24.1 + diff --git a/0007-Update-C-calling-conventions-to-the-RISC-V-ELF-psABI.patch b/0007-Update-C-calling-conventions-to-the-RISC-V-ELF-psABI.patch new file mode 100644 index 0000000..8160e82 --- /dev/null +++ b/0007-Update-C-calling-conventions-to-the-RISC-V-ELF-psABI.patch @@ -0,0 +1,59 @@ +From 5bc92d0cdb5cb26b8d8d517f30914c2b18e85f2b Mon Sep 17 00:00:00 2001 +From: Xavier Leroy +Date: Thu, 30 Apr 2020 16:19:16 +0200 +Subject: [PATCH 7/7] Update C calling conventions to the RISC-V ELF psABI + +The original implementation of loc_external_arguments and +loc_external_results was following an older ABI, +where an FP argument passed in an FP register "burns" an integer register. + +In the ELF psABI, integer registers and FP registers are used independently, +as in the OCaml calling convention. Plus, if all FP registers are used +but an integer register remains, the integer register is used to pass +the next FP argument. + +Fixes: #9515 +(cherry picked from commit ea6896f9f184305cc455d3af18cd1cb75cdcd93d) +--- + asmcomp/riscv/proc.ml | 11 +++++++---- + 1 file changed, 7 insertions(+), 4 deletions(-) + +diff --git a/asmcomp/riscv/proc.ml b/asmcomp/riscv/proc.ml +index 70909cd83..4c7b58612 100644 +--- a/asmcomp/riscv/proc.ml ++++ b/asmcomp/riscv/proc.ml +@@ -187,6 +187,8 @@ let loc_results res = + first integer args in a0 .. a7 + first float args in fa0 .. fa7 + remaining args on stack. ++ A FP argument can be passed in an integer register if all FP registers ++ are exhausted but integer registers remain. + Return values in a0 .. a1 or fa0 .. fa1. *) + + let external_calling_conventions +@@ -202,8 +204,7 @@ let external_calling_conventions + | Val | Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- [| phys_reg !int |]; +- incr int; +- incr float; ++ incr int + end else begin + loc.(i) <- [| stack_slot (make_stack !ofs) ty |]; + ofs := !ofs + size_int +@@ -211,8 +212,10 @@ let external_calling_conventions + | Float -> + if !float <= last_float then begin + loc.(i) <- [| phys_reg !float |]; +- incr float; +- incr int; ++ incr float ++ end else if !int <= last_int then begin ++ loc.(i) <- [| phys_reg !int |]; ++ incr int + end else begin + loc.(i) <- [| stack_slot (make_stack !ofs) Float |]; + ofs := !ofs + size_float +-- +2.24.1 + diff --git a/0007-x86-asm-handle-unit-names-with-special-characters-94.patch b/0007-x86-asm-handle-unit-names-with-special-characters-94.patch deleted file mode 100644 index 9ecfab9..0000000 --- a/0007-x86-asm-handle-unit-names-with-special-characters-94.patch +++ /dev/null @@ -1,55 +0,0 @@ -From 946b5c2563dbf7d8969781e6b05d9fc531cd65a2 Mon Sep 17 00:00:00 2001 -From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= -Date: Sun, 19 Apr 2020 11:17:00 +0200 -Subject: [PATCH 7/7] x86 asm: handle unit names with special characters - (#9465) - -(cherry picked from commit ec6690fb53b6caced797e1a7a083a787ff8bd97c) ---- - asmcomp/amd64/emit.mlp | 2 +- - testsuite/tests/asmcomp/0-!@#%.compilers.reference | 2 ++ - testsuite/tests/asmcomp/0-!@#%.ml | 10 ++++++++++ - 3 files changed, 13 insertions(+), 1 deletion(-) - create mode 100644 testsuite/tests/asmcomp/0-!@#%.compilers.reference - create mode 100644 testsuite/tests/asmcomp/0-!@#%.ml - -diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp -index 2e9e3a86d..d9c5eb6e6 100644 ---- a/asmcomp/amd64/emit.mlp -+++ b/asmcomp/amd64/emit.mlp -@@ -1146,7 +1146,7 @@ let end_assembly() = - }; - - if system = S_linux then begin -- let frametable = Compilenv.make_symbol (Some "frametable") in -+ let frametable = emit_symbol (Compilenv.make_symbol (Some "frametable")) in - D.size frametable (ConstSub (ConstThis, ConstLabel frametable)) - end; - -diff --git a/testsuite/tests/asmcomp/0-!@#%.compilers.reference b/testsuite/tests/asmcomp/0-!@#%.compilers.reference -new file mode 100644 -index 000000000..7df9a5456 ---- /dev/null -+++ b/testsuite/tests/asmcomp/0-!@#%.compilers.reference -@@ -0,0 +1,2 @@ -+File "0-!@#%.ml", line 1: -+Warning 24: bad source file name: "0-!@#%" is not a valid module name. -diff --git a/testsuite/tests/asmcomp/0-!@#%.ml b/testsuite/tests/asmcomp/0-!@#%.ml -new file mode 100644 -index 000000000..9f24bc382 ---- /dev/null -+++ b/testsuite/tests/asmcomp/0-!@#%.ml -@@ -0,0 +1,10 @@ -+(* TEST *) -+ -+(* We could not include the following characters the file name: -+ -+ - '$' : this character is interpreted specially by [ocamltest] (as it uses -+ [Buffer.add_substitute] on the filenames). -+ -+ - '^' : this character causes problems under Windows if not properly -+ quoted. In particular, flexlink needed to be adapted. -+*) --- -2.24.1 - diff --git a/ocaml.spec b/ocaml.spec index 34175e6..344936b 100644 --- a/ocaml.spec +++ b/ocaml.spec @@ -17,7 +17,7 @@ # These are all the architectures that the tests run on. The tests # take a long time to run, so don't run them on slow machines. -%global test_arches aarch64 %{power64} x86_64 +%global test_arches aarch64 %{power64} riscv64 x86_64 # These are the architectures for which the tests must pass otherwise # the build will fail. #global test_arches_required aarch64 ppc64le x86_64 @@ -31,7 +31,7 @@ Name: ocaml Version: 4.11.0 -Release: 0.3.pre%{?dist} +Release: 0.4.dev2%{?dist} Summary: OCaml compiler and programming environment @@ -40,9 +40,8 @@ License: QPL and (LGPLv2+ with exceptions) URL: http://www.ocaml.org #Source0: http://caml.inria.fr/pub/distrib/ocaml-4.10/ocaml-%{version}%{rcver}.tar.xz -# This is a pre-release of OCaml 4.11.0 with addition of the RISC-V -# patches. See: -# https://pagure.io/fedora-ocaml/commits/fedora-33-4.11.0-pre +# This is a pre-release of OCaml 4.11.0. See: +# https://pagure.io/fedora-ocaml/commits/fedora-33-4.11.0-dev2 Source0: ocaml-4.11.0.tar.gz # IMPORTANT NOTE: @@ -54,22 +53,21 @@ Source0: ocaml-4.11.0.tar.gz # # https://pagure.io/fedora-ocaml # -# Current branch: fedora-33-4.11.0-pre +# Current branch: fedora-33-4.11.0-dev2 # # ALTERNATIVELY add a patch to the end of the list (leaving the # existing patches unchanged) adding a comment to note that it should # be incorporated into the git repo at a later time. -# Fedora-specific downstream patches. Patch0001: 0001-Don-t-add-rpaths-to-libraries.patch Patch0002: 0002-configure-Allow-user-defined-C-compiler-flags.patch Patch0003: 0003-configure-Remove-incorrect-assumption-about-cross-co.patch Patch0004: 0004-Remove-configure-from-.gitattributes.patch -# All of these fixes are upstream in 4.11. -Patch0005: 0005-Merge-pull-request-9457-from-dra27-fix-mod_use.patch -Patch0006: 0006-Merge-pull-request-9463-from-lthls-fix_int64_cmm_typ.patch -Patch0007: 0007-x86-asm-handle-unit-names-with-special-characters-94.patch +# Add RISC-V backend. This is upstream in 4.12 (not 4.11). +Patch0005: 0005-Add-RISC-V-native-code-backend-9441.patch +Patch0006: 0006-Support-FP-reg-int-reg-moves.patch +Patch0007: 0007-Update-C-calling-conventions-to-the-RISC-V-ELF-psABI.patch BuildRequires: git BuildRequires: gcc @@ -242,6 +240,10 @@ find $RPM_BUILD_ROOT -name .ignore -delete # See also: http://www.ocamlpro.com/blog/2012/08/20/ocamlpro-and-4.00.0.html find $RPM_BUILD_ROOT \( -name '*.cmt' -o -name '*.cmti' \) -a -delete +# Remove this file. It's only created in certain situations and it's +# unclear why it is created at all. +rm -f $RPM_BUILD_ROOT%{_libdir}/ocaml/eventlog_metadata + %files %doc LICENSE @@ -249,8 +251,10 @@ find $RPM_BUILD_ROOT \( -name '*.cmt' -o -name '*.cmti' \) -a -delete %{_bindir}/ocamlcmt %{_bindir}/ocamldebug +%ifnarch riscv64 %{_bindir}/ocaml-instr-graph %{_bindir}/ocaml-instr-report +%endif %{_bindir}/ocamlyacc # symlink to either .byte or .opt version @@ -373,6 +377,12 @@ find $RPM_BUILD_ROOT \( -name '*.cmt' -o -name '*.cmti' \) -a -delete %changelog +* Mon May 04 2020 Richard W.M. Jones - 4.11.0-0.4.dev2.fc33 +- Move to OCaml 4.11.0+dev2-2020-04-22. +- Backport upstream RISC-V backend from 4.12 + fixes. +- Enable tests on riscv64. +- Disable ocaml-instr-* tools on riscv64. + * Tue Apr 21 2020 Richard W.M. Jones - 4.11.0-0.3.pre.fc33 - Add fixes for various issues found in the previous build. diff --git a/sources b/sources index 582776a..9c55304 100644 --- a/sources +++ b/sources @@ -1 +1 @@ -SHA512 (ocaml-4.11.0.tar.gz) = 3d41e50b73981af1f6d5e51cf1878a2fd54b52a4da434298a48159d48ea66166689c2fb30a8fe6a9e8dd6f4a483009af24e550fb03fa6dc736b6bf37c4534645 +SHA512 (ocaml-4.11.0.tar.gz) = b07208b8679ef285f30b2da4070a3cf894cb881b79330e1ee50839fff634e58be1b7c378690658d146d2565ddbfa40aaa12ecec9558d7eab501b1863f50bfc88