rpms/ocaml
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix RISC-V backend.

Browse Source
This commit is contained in:
Richard W.M. Jones 2020-04-11 18:20:06 +01:00
parent 7c612a100b
commit db6ffb193e
9 changed files with 2748 additions and 542 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
0001-Don-t-add-rpaths-to-libraries.patch
View File

@ -1,7 +1,7 @@
From bf123e43c444ff14fcb76f806d90806e4960a1a4 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 24 Jun 2014 10:00:15 +0100
Subject: [PATCH 1/5] Don't add rpaths to libraries.
Subject: [PATCH 1/8] Don't add rpaths to libraries.
---
tools/Makefile | 4 ++--
@ -23,5 +23,5 @@ index 18aead935..e374c05ee 100644
> ocamlmklibconfig.ml
--
2.25.0
2.24.1

4
0002-configure-Allow-user-defined-C-compiler-flags.patch
View File

@ -1,7 +1,7 @@
From 3a5dfecb2e4078bcd7388412783b50014006e7c9 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 29 May 2012 20:44:18 +0100
Subject: [PATCH 2/5] configure: Allow user defined C compiler flags.
Subject: [PATCH 2/8] configure: Allow user defined C compiler flags.
---
configure.ac | 4 ++++
@ -23,5 +23,5 @@ index e3e28fb6f..0648f0553 100644
# Enable SSE2 on x86 mingw to avoid using 80-bit registers.
--
2.25.0
2.24.1

4
0003-configure-Remove-incorrect-assumption-about-cross-co.patch
View File

@ -1,7 +1,7 @@
From b32e6fc3318a2d25d7ae233a8999beb752d6131d Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Fri, 26 Apr 2019 16:16:29 +0100
Subject: [PATCH 3/5] configure: Remove incorrect assumption about
Subject: [PATCH 3/8] configure: Remove incorrect assumption about
cross-compiling.
See https://github.com/ocaml/ocaml/issues/8647#issuecomment-487094390
@ -39,5 +39,5 @@ index 0648f0553..ad07516e7 100644
# We first compute default values for as and aspp
# If values have been given by the user then they take precedence over
--
2.25.0
2.24.1

4
0004-Remove-configure-from-.gitattributes.patch
View File

@ -1,7 +1,7 @@
From 9ea729ce863396484d2e4c5a93af4b625fc5c90c Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 18 Jan 2020 11:31:27 +0000
Subject: [PATCH 4/5] Remove configure from .gitattributes.
Subject: [PATCH 4/8] Remove configure from .gitattributes.
It's not a binary file.
---
@ -24,5 +24,5 @@ index 9be9e33a0..5df88ab4e 100644
# http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/
/.mailmap merge=union
--
2.25.0
2.24.1

504
0005-Use-a-more-compact-representation-of-debug-informati.patch Normal file
View File

@ -0,0 +1,504 @@
From f54d138e2cbabbfb6488a1605f995aaf4a663e0b Mon Sep 17 00:00:00 2001
From: Stephen Dolan <sdolan@janestreet.com>
Date: Tue, 23 Apr 2019 14:11:11 +0100
Subject: [PATCH 5/8] Use a more compact representation of debug information.
Locations of inlined frames are now represented as contiguous
sequences rather than linked lists.
The frame tables now refer to debug info by 32-bit offset rather
than word-sized pointer.
(cherry picked from commit b0ad600b88b3eb6e53be681794f36dd58b6a493d)
---
Changes | 1 -
asmcomp/amd64/emit.mlp | 38 ++++++++-------
asmcomp/emitaux.ml | 88 ++++++++++++++++++++---------------
asmcomp/emitaux.mli | 8 +++-
runtime/backtrace_nat.c | 34 ++++++++------
runtime/caml/backtrace_prim.h | 2 +-
runtime/caml/stack.h | 12 ++++-
runtime/roots_nat.c | 22 +++++----
8 files changed, 124 insertions(+), 81 deletions(-)
diff --git a/Changes b/Changes
index fc5591eb4..fef04de44 100644
--- a/Changes
+++ b/Changes
@@ -565,7 +565,6 @@ OCaml 4.09.0 (19 September 2019):
- #8787, #8788: avoid integer overflow in caml_output_value_to_bytes
(Jeremy Yallop, report by Marcello Seri)
-
- #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime
in order to avoid compiler warning
(Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp)
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index e3ff9653d..69cc48b6d 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -239,7 +239,7 @@ let addressing addr typ i n =
(* Record live pointers at call points -- see Emitaux *)
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -258,11 +258,11 @@ let record_frame_label ?label live raise_ dbg =
)
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
lbl
-let record_frame ?label live raise_ dbg =
- let lbl = record_frame_label ?label live raise_ dbg in
+let record_frame ?label live dbg =
+ let lbl = record_frame_label ?label live dbg in
def_label lbl
(* Spacetime instrumentation *)
@@ -327,7 +327,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg ~spacetime =
if !Clflags.debug || Config.spacetime then begin
let lbl_bound_error = new_label() in
- let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg 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_frame;
bd_spacetime = spacetime; } :: !bound_error_sites;
@@ -573,16 +573,16 @@ let emit_instr fallthrough i =
load_symbol_addr s (res i 0)
| Lop(Icall_ind { label_after; }) ->
I.call (arg i 0);
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| Lop(Icall_imm { func; label_after; }) ->
add_used_symbol func;
emit_call func;
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| Lop(Itailcall_ind { label_after; }) ->
output_epilogue begin fun () ->
I.jmp (arg i 0);
if Config.spacetime then begin
- record_frame Reg.Set.empty false i.dbg ~label:label_after
+ record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
end
end
| Lop(Itailcall_imm { func; label_after; }) ->
@@ -597,14 +597,14 @@ let emit_instr fallthrough i =
end
end;
if Config.spacetime then begin
- record_frame Reg.Set.empty false i.dbg ~label:label_after
+ record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
end
| Lop(Iextcall { func; alloc; label_after; }) ->
add_used_symbol func;
if alloc then begin
load_symbol_addr func rax;
emit_call "caml_c_call";
- record_frame i.live false i.dbg ~label:label_after;
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after;
if system <> S_win64 then begin
(* TODO: investigate why such a diff.
This comes from:
@@ -618,7 +618,7 @@ let emit_instr fallthrough i =
end else begin
emit_call func;
if Config.spacetime then begin
- record_frame Reg.Set.empty false i.dbg ~label:label_after
+ record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
end
end
| Lop(Istackoffset n) ->
@@ -668,7 +668,7 @@ let emit_instr fallthrough i =
I.movsd (arg i 0) (addressing addr REAL8 i 1)
end
| Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; }) ->
- if !fastcode_flag then begin
+ if !fastcode_flag then begin
let lbl_redo = new_label() in
def_label lbl_redo;
I.sub (int n) r15;
@@ -679,7 +679,7 @@ let emit_instr fallthrough i =
else i.dbg
in
let lbl_frame =
- record_frame_label ?label:label_after_call_gc i.live false dbg
+ record_frame_label ?label:label_after_call_gc i.live (Dbg_other dbg)
in
I.jb (label lbl_call_gc);
I.lea (mem64 NONE 8 R15) (res i 0);
@@ -707,8 +707,8 @@ let emit_instr fallthrough i =
emit_call "caml_allocN"
end;
let label =
- record_frame_label ?label:label_after_call_gc i.live false
- Debuginfo.none
+ record_frame_label ?label:label_after_call_gc i.live
+ (Dbg_other i.dbg)
in
def_label label;
I.lea (mem64 NONE 8 R15) (res i 0)
@@ -914,10 +914,10 @@ let emit_instr fallthrough i =
| Lambda.Raise_regular ->
I.mov (int 0) (domain_field Domainstate.Domain_backtrace_pos);
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg
+ record_frame Reg.Set.empty (Dbg_raise i.dbg)
| Lambda.Raise_reraise ->
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg
+ record_frame Reg.Set.empty (Dbg_raise i.dbg)
| Lambda.Raise_notrace ->
I.mov (domain_field Domainstate.Domain_exception_pointer) rsp;
I.pop (domain_field Domainstate.Domain_exception_pointer);
@@ -1119,6 +1119,7 @@ let end_assembly() =
emit_frames
{ efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l)));
efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+ efa_8 = (fun n -> D.byte (const n));
efa_16 = (fun n -> D.word (const n));
efa_32 = (fun n -> D.long (const_32 n));
efa_word = (fun n -> D.qword (const n));
@@ -1142,6 +1143,9 @@ let end_assembly() =
efa_string = (fun s -> D.bytes (s ^ "\000"))
};
+ let frametable = Compilenv.make_symbol (Some "frametable") in
+ D.size frametable (ConstSub (ConstThis, ConstLabel frametable));
+
if Config.spacetime then begin
emit_spacetime_shapes ()
end;
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index e0476d171..9e7221096 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -105,26 +105,29 @@ let emit_float32_directive directive x =
(* Record live pointers at call points *)
+type frame_debuginfo =
+ | Dbg_raise of Debuginfo.t
+ | Dbg_other of Debuginfo.t
+
type frame_descr =
{ fd_lbl: int; (* Return address *)
fd_frame_size: int; (* Size of stack frame *)
fd_live_offset: int list; (* Offsets/regs of live addresses *)
- fd_raise: bool; (* Is frame for a raise? *)
- fd_debuginfo: Debuginfo.t } (* Location, if any *)
+ fd_debuginfo: frame_debuginfo } (* Location, if any *)
let frame_descriptors = ref([] : frame_descr list)
-let record_frame_descr ~label ~frame_size ~live_offset ~raise_frame debuginfo =
+let record_frame_descr ~label ~frame_size ~live_offset debuginfo =
frame_descriptors :=
{ fd_lbl = label;
fd_frame_size = frame_size;
fd_live_offset = List.sort_uniq (-) live_offset;
- fd_raise = raise_frame;
fd_debuginfo = debuginfo } :: !frame_descriptors
type emit_frame_actions =
{ efa_code_label: int -> unit;
efa_data_label: int -> unit;
+ efa_8: int -> unit;
efa_16: int -> unit;
efa_32: int32 -> unit;
efa_word: int -> unit;
@@ -155,64 +158,73 @@ let emit_frames a =
end)
in
let debuginfos = Label_table.create 7 in
- let rec label_debuginfos rs rdbg =
+ let label_debuginfos rs dbg =
+ let rdbg = List.rev dbg in
let key = (rs, rdbg) in
- try fst (Label_table.find debuginfos key)
+ try Label_table.find debuginfos key
with Not_found ->
let lbl = Cmm.new_label () in
- let next =
- match rdbg with
- | [] -> assert false
- | _ :: [] -> None
- | _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg')
- in
- Label_table.add debuginfos key (lbl, next);
+ Label_table.add debuginfos key lbl;
lbl
in
- let emit_debuginfo_label rs rdbg =
- a.efa_data_label (label_debuginfos rs rdbg)
- in
let emit_frame fd =
+ assert (fd.fd_frame_size land 3 = 0);
+ let flags =
+ match fd.fd_debuginfo with
+ | Dbg_other d | Dbg_raise d ->
+ if Debuginfo.is_none d then 0 else 1
+ in
a.efa_code_label fd.fd_lbl;
- a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo
- then fd.fd_frame_size
- else fd.fd_frame_size + 1);
+ a.efa_16 (fd.fd_frame_size + flags);
a.efa_16 (List.length fd.fd_live_offset);
List.iter a.efa_16 fd.fd_live_offset;
- a.efa_align Arch.size_addr;
- match List.rev fd.fd_debuginfo with
- | [] -> ()
- | _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg
+ begin match fd.fd_debuginfo with
+ | _ when flags = 0 ->
+ ()
+ | Dbg_other dbg ->
+ a.efa_align 4;
+ a.efa_label_rel (label_debuginfos false dbg) Int32.zero
+ | Dbg_raise dbg ->
+ a.efa_align 4;
+ a.efa_label_rel (label_debuginfos true dbg) Int32.zero
+ end;
+ a.efa_align Arch.size_addr
in
let emit_filename name lbl =
a.efa_def_label lbl;
a.efa_string name;
a.efa_align Arch.size_addr
in
- let pack_info fd_raise d =
+ let pack_info fd_raise d has_next =
let line = min 0xFFFFF d.Debuginfo.dinfo_line
and char_start = min 0xFF d.Debuginfo.dinfo_char_start
and char_end = min 0x3FF d.Debuginfo.dinfo_char_end
- and kind = if fd_raise then 1 else 0 in
+ and kind = if fd_raise then 1 else 0
+ and has_next = if has_next then 1 else 0 in
Int64.(add (shift_left (of_int line) 44)
(add (shift_left (of_int char_start) 36)
(add (shift_left (of_int char_end) 26)
- (of_int kind))))
+ (add (shift_left (of_int kind) 1)
+ (of_int has_next)))))
in
- let emit_debuginfo (rs, rdbg) (lbl,next) =
- let d = List.hd rdbg in
+ let emit_debuginfo (rs, rdbg) lbl =
+ (* Due to inlined functions, a single debuginfo may have multiple locations.
+ These are represented sequentially in memory (innermost frame first),
+ with the low bit of the packed debuginfo being 0 on the last entry. *)
a.efa_align Arch.size_addr;
a.efa_def_label lbl;
- let info = pack_info rs d in
- a.efa_label_rel
- (label_filename d.Debuginfo.dinfo_file)
- (Int64.to_int32 info);
- a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
- begin match next with
- | Some next -> a.efa_data_label next
- | None -> a.efa_word 0
- end
- in
+ let rec emit rs d rest =
+ let info = pack_info rs d (rest <> []) in
+ a.efa_label_rel
+ (label_filename d.Debuginfo.dinfo_file)
+ (Int64.to_int32 info);
+ a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
+ match rest with
+ | [] -> ()
+ | d :: rest -> emit false d rest in
+ match rdbg with
+ | [] -> assert false
+ | d :: rest -> emit rs d rest in
a.efa_word (List.length !frame_descriptors);
List.iter emit_frame !frame_descriptors;
Label_table.iter emit_debuginfo debuginfos;
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index b2b2141c5..a4a60e07c 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -38,17 +38,21 @@ val emit_debug_info_gen :
(file_num:int -> file_name:string -> unit) ->
(file_num:int -> line:int -> col:int -> unit) -> unit
+type frame_debuginfo =
+ | Dbg_raise of Debuginfo.t
+ | Dbg_other of Debuginfo.t
+
val record_frame_descr :
label:int -> (* Return address *)
frame_size:int -> (* Size of stack frame *)
live_offset:int list -> (* Offsets/regs of live addresses *)
- raise_frame:bool -> (* Is frame for a raise? *)
- Debuginfo.t -> (* Location, if any *)
+ frame_debuginfo -> (* Location, if any *)
unit
type emit_frame_actions =
{ efa_code_label: int -> unit;
efa_data_label: int -> unit;
+ efa_8: int -> unit;
efa_16: int -> unit;
efa_32: int32 -> unit;
efa_word: int -> unit;
diff --git a/runtime/backtrace_nat.c b/runtime/backtrace_nat.c
index 81cb6d8e1..acf31d644 100644
--- a/runtime/backtrace_nat.c
+++ b/runtime/backtrace_nat.c
@@ -137,18 +137,20 @@ void caml_current_callstack_write(value trace) {
debuginfo caml_debuginfo_extract(backtrace_slot slot)
{
- uintnat infoptr;
+ unsigned char* infoptr;
+ uint32_t debuginfo_offset;
frame_descr * d = (frame_descr *)slot;
if ((d->frame_size & 1) == 0) {
return NULL;
}
/* Recover debugging info */
- infoptr = ((uintnat) d +
- sizeof(char *) + sizeof(short) + sizeof(short) +
- sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
- & -sizeof(frame_descr *);
- return *((debuginfo*)infoptr);
+ infoptr = (unsigned char*)&d->live_ofs[d->num_live];
+ /* align to 32 bits */
+ infoptr = Align_to(infoptr, uint32_t);
+ /* read offset to debuginfo */
+ debuginfo_offset = *(uint32_t*)infoptr;
+ return (debuginfo)(infoptr + debuginfo_offset);
}
debuginfo caml_debuginfo_next(debuginfo dbg)
@@ -159,8 +161,12 @@ debuginfo caml_debuginfo_next(debuginfo dbg)
return NULL;
infoptr = dbg;
- infoptr += 2; /* Two packed info fields */
- return *((debuginfo*)infoptr);
+ if ((infoptr[0] & 1) == 0)
+ /* No next debuginfo */
+ return NULL;
+ else
+ /* Next debuginfo is after the two packed info fields */
+ return (debuginfo*)(infoptr + 2);
}
/* Extract location information for the given frame descriptor */
@@ -181,17 +187,19 @@ void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
info1 = ((uint32_t *)dbg)[0];
info2 = ((uint32_t *)dbg)[1];
/* Format of the two info words:
- llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
- 44 36 26 2 0
+ llllllllllllllllllll aaaaaaaa bbbbbbbbbb ffffffffffffffffffffffff k n
+ 44 36 26 2 1 0
(32+12) (32+4)
- k ( 2 bits): 0 if it's a call
+ n ( 1 bit ): 0 if this is the final debuginfo
+ 1 if there's another following this one
+ k ( 1 bit ): 0 if it's a call
1 if it's a raise
- n (24 bits): offset (in 4-byte words) of file name relative to dbg
+ f (24 bits): offset (in 4-byte words) of file name relative to dbg
l (20 bits): line number
a ( 8 bits): beginning of character range
b (10 bits): end of character range */
li->loc_valid = 1;
- li->loc_is_raise = (info1 & 3) == 1;
+ li->loc_is_raise = (info1 & 2) == 2;
li->loc_is_inlined = caml_debuginfo_next(dbg) != NULL;
li->loc_filename = (char *) dbg + (info1 & 0x3FFFFFC);
li->loc_lnum = info2 >> 12;
diff --git a/runtime/caml/backtrace_prim.h b/runtime/caml/backtrace_prim.h
index 08c236047..4d8ce9096 100644
--- a/runtime/caml/backtrace_prim.h
+++ b/runtime/caml/backtrace_prim.h
@@ -43,7 +43,7 @@ struct caml_loc_info {
};
/* When compiling with -g, backtrace slots have debug info associated.
- * When a call is inlined in native mode, debuginfos form a linked list.
+ * When a call is inlined in native mode, debuginfos form a sequence.
*/
typedef void * debuginfo;
diff --git a/runtime/caml/stack.h b/runtime/caml/stack.h
index 259f97ac4..30a18d274 100644
--- a/runtime/caml/stack.h
+++ b/runtime/caml/stack.h
@@ -87,9 +87,19 @@ typedef struct {
uintnat retaddr;
unsigned short frame_size;
unsigned short num_live;
- unsigned short live_ofs[1];
+ unsigned short live_ofs[1 /* num_live */];
+ /*
+ If frame_size & 1, then debug info follows:
+ uint32_t debug_info_offset;
+ Debug info is stored as a relative offset to a debuginfo structure. */
} frame_descr;
+/* Used to compute offsets in frame tables.
+ ty must have power-of-2 size */
+#define Align_to(p, ty) \
+ (void*)(((uintnat)(p) + sizeof(ty) - 1) & -sizeof(ty))
+
+
/* Hash table of frame descriptors */
extern frame_descr ** caml_frame_descriptors;
diff --git a/runtime/roots_nat.c b/runtime/roots_nat.c
index d8feb1bdc..f61e56d90 100644
--- a/runtime/roots_nat.c
+++ b/runtime/roots_nat.c
@@ -29,6 +29,7 @@
#include "caml/memprof.h"
#include <string.h>
#include <stdio.h>
+#include <stddef.h>
/* Roots registered from C functions */
@@ -78,14 +79,19 @@ static link* frametables_list_tail(link *list) {
}
static frame_descr * next_frame_descr(frame_descr * d) {
- uintnat nextd;
- nextd =
- ((uintnat)d +
- sizeof(char *) + sizeof(short) + sizeof(short) +
- sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
- & -sizeof(frame_descr *);
- if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */
- return((frame_descr *) nextd);
+ unsigned char num_allocs = 0, *p;
+ CAMLassert(d->retaddr >= 4096);
+ /* Skip to end of live_ofs */
+ p = (unsigned char*)&d->live_ofs[d->num_live];
+ /* Skip debug info if present */
+ if (d->frame_size & 1) {
+ /* Align to 32 bits */
+ p = Align_to(p, uint32_t);
+ p += sizeof(uint32_t) * (d->frame_size & 2 ? num_allocs : 1);
+ }
+ /* Align to word size */
+ p = Align_to(p, void*);
+ return ((frame_descr*) p);
}
static void fill_hashtable(link *frametables) {
--
2.24.1

620
0006-Retain-debug-information-about-allocation-sizes-for-.patch Normal file
View File

@ -0,0 +1,620 @@
From dac12e5db7f4ca4a32b0eccea1d16d27f9df86d2 Mon Sep 17 00:00:00 2001
From: Stephen Dolan <sdolan@janestreet.com>
Date: Tue, 16 Jul 2019 16:24:01 +0100
Subject: [PATCH 6/8] Retain debug information about allocation sizes, for
statmemprof.
This code is adapted from jhjourdan's 2c93ca1e711. Comballoc is
extended to keep track of allocation sizes and debug info for each
allocation, and the frame table format is modified to store them.
The native code GC-entry logic is changed to match bytecode, by
calling the garbage collector at most once per allocation.
amd64 only, for now.
(cherry picked from commit 34f97941ec302129f516c926c9ef65e4d68b8121)
---
asmcomp/amd64/emit.mlp | 30 ++++++++-----------
asmcomp/comballoc.ml | 55 +++++++++++++++++++---------------
asmcomp/emitaux.ml | 22 ++++++++++++++
asmcomp/emitaux.mli | 1 +
asmcomp/mach.ml | 6 +++-
asmcomp/mach.mli | 11 ++++++-
asmcomp/selectgen.ml | 8 +++--
asmcomp/spacetime_profiling.ml | 1 +
runtime/amd64.S | 53 ++++----------------------------
runtime/backtrace_nat.c | 16 ++++++++--
runtime/caml/stack.h | 10 +++++--
runtime/minor_gc.c | 5 ++++
runtime/roots_nat.c | 5 ++++
runtime/signals_nat.c | 37 +++++++++++------------
14 files changed, 143 insertions(+), 117 deletions(-)
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 69cc48b6d..6c3950a6d 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -299,13 +299,7 @@ let emit_call_gc gc =
assert Config.spacetime;
spacetime_before_uninstrumented_call ~node_ptr ~index
end;
- begin match gc.gc_size with
- | 16 -> emit_call "caml_call_gc1"
- | 24 -> emit_call "caml_call_gc2"
- | 32 -> emit_call "caml_call_gc3"
- | n -> I.add (int n) r15;
- emit_call "caml_call_gc"
- end;
+ emit_call "caml_call_gc";
def_label gc.gc_frame;
I.jmp (label gc.gc_return_lbl)
@@ -667,21 +661,21 @@ let emit_instr fallthrough i =
| Double | Double_u ->
I.movsd (arg i 0) (addressing addr REAL8 i 1)
end
- | Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; }) ->
- if !fastcode_flag then begin
- let lbl_redo = new_label() in
- def_label lbl_redo;
+ | Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; dbginfo }) ->
+ let dbginfo =
+ if not !Clflags.debug && not Config.spacetime then
+ List.map (fun d -> { d with alloc_dbg = Debuginfo.none }) dbginfo
+ else dbginfo in
+ if !fastcode_flag then begin
I.sub (int n) r15;
I.cmp (domain_field Domainstate.Domain_young_limit) r15;
let lbl_call_gc = new_label() in
- let dbg =
- if not Config.spacetime then Debuginfo.none
- else i.dbg
- in
let lbl_frame =
- record_frame_label ?label:label_after_call_gc i.live (Dbg_other dbg)
+ record_frame_label ?label:label_after_call_gc i.live (Dbg_alloc dbginfo)
in
I.jb (label lbl_call_gc);
+ let lbl_after_alloc = new_label() in
+ def_label lbl_after_alloc;
I.lea (mem64 NONE 8 R15) (res i 0);
let gc_spacetime =
if not Config.spacetime then None
@@ -690,7 +684,7 @@ let emit_instr fallthrough i =
call_gc_sites :=
{ gc_size = n;
gc_lbl = lbl_call_gc;
- gc_return_lbl = lbl_redo;
+ gc_return_lbl = lbl_after_alloc;
gc_frame = lbl_frame;
gc_spacetime; } :: !call_gc_sites
end else begin
@@ -708,7 +702,7 @@ let emit_instr fallthrough i =
end;
let label =
record_frame_label ?label:label_after_call_gc i.live
- (Dbg_other i.dbg)
+ (Dbg_alloc dbginfo)
in
def_label label;
I.lea (mem64 NONE 8 R15) (res i 0)
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
index 29ee15b36..b8ebcf374 100644
--- a/asmcomp/comballoc.ml
+++ b/asmcomp/comballoc.ml
@@ -17,34 +17,41 @@
open Mach
+type pending_alloc =
+ { reg: Reg.t; (* register holding the result of the last allocation *)
+ dbginfos: alloc_dbginfo list; (* debug info for each pending allocation *)
+ totalsz: int } (* amount to be allocated in this block *)
+
type allocation_state =
No_alloc
- | Pending_alloc of
- { reg: Reg.t; (* register holding the result of the last allocation *)
- totalsz: int } (* amount to be allocated in this block *)
-
-let allocated_size = function
- No_alloc -> 0
- | Pending_alloc {totalsz; _} -> totalsz
+ | Pending_alloc of pending_alloc
let rec combine i allocstate =
match i.desc with
Iend | Ireturn | Iexit _ | Iraise _ ->
- (i, allocated_size allocstate)
- | Iop(Ialloc { bytes = sz; _ }) ->
+ (i, allocstate)
+ | Iop(Ialloc { bytes = sz; dbginfo; _ }) ->
begin match allocstate with
- | Pending_alloc {reg; totalsz}
+ | Pending_alloc {reg; dbginfos; totalsz}
when totalsz + sz < Config.max_young_wosize * Arch.size_addr ->
let (next, totalsz) =
combine i.next
- (Pending_alloc { reg = i.res.(0); totalsz = totalsz + sz }) in
+ (Pending_alloc { reg = i.res.(0);
+ dbginfos = dbginfo @ dbginfos;
+ totalsz = totalsz + sz }) in
(instr_cons_debug (Iop(Iintop_imm(Iadd, -sz)))
[| reg |] i.res i.dbg next,
totalsz)
| No_alloc | Pending_alloc _ ->
- let (next, totalsz) =
+ let (next, state) =
combine i.next
- (Pending_alloc { reg = i.res.(0); totalsz = sz }) in
+ (Pending_alloc { reg = i.res.(0);
+ dbginfos = dbginfo;
+ totalsz = sz }) in
+ let totalsz, dbginfo =
+ match state with
+ | No_alloc -> 0, dbginfo
+ | Pending_alloc { totalsz; dbginfos; _ } -> totalsz, dbginfos in
let next =
let offset = totalsz - sz in
if offset = 0 then next
@@ -52,40 +59,40 @@ let rec combine i allocstate =
i.res i.dbg next
in
(instr_cons_debug (Iop(Ialloc {bytes = totalsz; spacetime_index = 0;
- label_after_call_gc = None; }))
- i.arg i.res i.dbg next, allocated_size allocstate)
+ dbginfo; label_after_call_gc = None; }))
+ i.arg i.res i.dbg next, allocstate)
end
| Iop(Icall_ind _ | Icall_imm _ | Iextcall _ |
Itailcall_ind _ | Itailcall_imm _) ->
let newnext = combine_restart i.next in
(instr_cons_debug i.desc i.arg i.res i.dbg newnext,
- allocated_size allocstate)
+ allocstate)
| Iop _ ->
- let (newnext, sz) = combine i.next allocstate in
- (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz)
+ let (newnext, s') = combine i.next allocstate in
+ (instr_cons_debug i.desc i.arg i.res i.dbg newnext, s')
| Iifthenelse(test, ifso, ifnot) ->
let newifso = combine_restart ifso in
let newifnot = combine_restart ifnot in
let newnext = combine_restart i.next in
(instr_cons (Iifthenelse(test, newifso, newifnot)) i.arg i.res newnext,
- allocated_size allocstate)
+ allocstate)
| Iswitch(table, cases) ->
let newcases = Array.map combine_restart cases in
let newnext = combine_restart i.next in
(instr_cons (Iswitch(table, newcases)) i.arg i.res newnext,
- allocated_size allocstate)
+ allocstate)
| Icatch(rec_flag, handlers, body) ->
- let (newbody, sz) = combine body allocstate in
+ let (newbody, s') = combine body allocstate in
let newhandlers =
List.map (fun (io, handler) -> io, combine_restart handler) handlers in
let newnext = combine_restart i.next in
(instr_cons (Icatch(rec_flag, newhandlers, newbody))
- i.arg i.res newnext, sz)
+ i.arg i.res newnext, s')
| Itrywith(body, handler) ->
- let (newbody, sz) = combine body allocstate in
+ let (newbody, s') = combine body allocstate in
let newhandler = combine_restart handler in
let newnext = combine_restart i.next in
- (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, sz)
+ (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, s')
and combine_restart i =
let (newi, _) = combine i No_alloc in newi
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index 9e7221096..8ed63af28 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -106,6 +106,7 @@ let emit_float32_directive directive x =
(* Record live pointers at call points *)
type frame_debuginfo =
+ | Dbg_alloc of Mach.alloc_dbginfo list
| Dbg_raise of Debuginfo.t
| Dbg_other of Debuginfo.t
@@ -173,6 +174,10 @@ let emit_frames a =
match fd.fd_debuginfo with
| Dbg_other d | Dbg_raise d ->
if Debuginfo.is_none d then 0 else 1
+ | Dbg_alloc dbgs ->
+ if List.for_all (fun d ->
+ Debuginfo.is_none d.Mach.alloc_dbg) dbgs
+ then 2 else 3
in
a.efa_code_label fd.fd_lbl;
a.efa_16 (fd.fd_frame_size + flags);
@@ -187,6 +192,23 @@ let emit_frames a =
| Dbg_raise dbg ->
a.efa_align 4;
a.efa_label_rel (label_debuginfos true dbg) Int32.zero
+ | Dbg_alloc dbg ->
+ assert (List.length dbg < 256);
+ a.efa_8 (List.length dbg);
+ List.iter (fun Mach.{alloc_words;_} ->
+ (* Possible allocations range between 2 and 257 *)
+ assert (2 <= alloc_words &&
+ alloc_words - 1 <= Config.max_young_wosize &&
+ Config.max_young_wosize <= 256);
+ a.efa_8 (alloc_words - 2)) dbg;
+ if flags = 3 then begin
+ a.efa_align 4;
+ List.iter (fun Mach.{alloc_dbg; _} ->
+ if Debuginfo.is_none alloc_dbg then
+ a.efa_32 Int32.zero
+ else
+ a.efa_label_rel (label_debuginfos false alloc_dbg) Int32.zero) dbg
+ end
end;
a.efa_align Arch.size_addr
in
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index a4a60e07c..1a8982a07 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -39,6 +39,7 @@ val emit_debug_info_gen :
(file_num:int -> line:int -> col:int -> unit) -> unit
type frame_debuginfo =
+ | Dbg_alloc of Mach.alloc_dbginfo list
| Dbg_raise of Debuginfo.t
| Dbg_other of Debuginfo.t
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index ab69e0ca3..8df94d039 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -39,6 +39,10 @@ type test =
| Ioddtest
| Ieventest
+type alloc_dbginfo =
+ { alloc_words : int;
+ alloc_dbg : Debuginfo.t }
+
type operation =
Imove
| Ispill
@@ -55,7 +59,7 @@ type operation =
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
| Ialloc of { bytes : int; label_after_call_gc : label option;
- spacetime_index : int; }
+ dbginfo : alloc_dbginfo list; spacetime_index : int; }
| Iintop of integer_operation
| Iintop_imm of integer_operation * int
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index 5df79585c..fd3e033bf 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -46,6 +46,15 @@ type test =
| Ioddtest
| Ieventest
+type alloc_dbginfo =
+ { alloc_words : int;
+ alloc_dbg : Debuginfo.t }
+(** Due to Comballoc, a single Ialloc instruction may combine several
+ unrelated allocations. Their Debuginfo.t (which may differ) are stored
+ as a list of alloc_dbginfo. This list is in order of increasing memory
+ address, which is the reverse of the original allocation order. Later
+ allocations are consed to the front of this list by Comballoc. *)
+
type operation =
Imove
| Ispill
@@ -63,7 +72,7 @@ type operation =
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
(* false = initialization, true = assignment *)
| Ialloc of { bytes : int; label_after_call_gc : label option;
- spacetime_index : int; }
+ dbginfo : alloc_dbginfo list; spacetime_index : int; }
(** For Spacetime only, Ialloc instructions take one argument, being the
pointer to the trie node for the current function. *)
| Iintop of integer_operation
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index b024dfe7d..d5f54b699 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -419,7 +419,8 @@ method mark_instr = function
(* Default instruction selection for operators *)
method select_allocation bytes =
- Ialloc { bytes; spacetime_index = 0; label_after_call_gc = None; }
+ Ialloc { bytes; label_after_call_gc = None;
+ dbginfo = []; spacetime_index = 0; }
method select_allocation_args _env = [| |]
method select_checkbound () =
@@ -775,8 +776,11 @@ method emit_expr (env:environment) exp =
| Ialloc { bytes = _; spacetime_index; label_after_call_gc; } ->
let rd = self#regs_for typ_val in
let bytes = size_expr env (Ctuple new_args) in
+ assert (bytes mod Arch.size_addr = 0);
+ let alloc_words = bytes / Arch.size_addr in
let op =
- Ialloc { bytes; spacetime_index; label_after_call_gc; }
+ Ialloc { bytes; spacetime_index; label_after_call_gc;
+ dbginfo = [{alloc_words; alloc_dbg = dbg}] }
in
let args = self#select_allocation_args env in
self#insert_debug env (Iop op) dbg args rd;
diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml
index a61cd1c43..62e182ab9 100644
--- a/asmcomp/spacetime_profiling.ml
+++ b/asmcomp/spacetime_profiling.ml
@@ -396,6 +396,7 @@ class virtual instruction_selection = object (self)
in
Mach.Ialloc {
bytes;
+ dbginfo = [];
label_after_call_gc = Some label;
spacetime_index = index;
}
diff --git a/runtime/amd64.S b/runtime/amd64.S
index 77a4f85aa..03c1f4e81 100644
--- a/runtime/amd64.S
+++ b/runtime/amd64.S
@@ -425,111 +425,70 @@ ENDFUNCTION(G(caml_call_gc))
FUNCTION(G(caml_alloc1))
CFI_STARTPROC
-LBL(caml_alloc1):
subq $16, %r15
cmpq Caml_state(young_limit), %r15
jb LBL(100)
ret
LBL(100):
- addq $16, %r15
RECORD_STACK_FRAME(0)
ENTER_FUNCTION
/* subq $8, %rsp; CFI_ADJUST (8); */
call LBL(caml_call_gc)
/* addq $8, %rsp; CFI_ADJUST (-8); */
LEAVE_FUNCTION
- jmp LBL(caml_alloc1)
+ ret
CFI_ENDPROC
ENDFUNCTION(G(caml_alloc1))
FUNCTION(G(caml_alloc2))
CFI_STARTPROC
-LBL(caml_alloc2):
subq $24, %r15
cmpq Caml_state(young_limit), %r15
jb LBL(101)
ret
LBL(101):
- addq $24, %r15
RECORD_STACK_FRAME(0)
ENTER_FUNCTION
/* subq $8, %rsp; CFI_ADJUST (8); */
call LBL(caml_call_gc)
/* addq $8, %rsp; CFI_ADJUST (-8); */
LEAVE_FUNCTION
- jmp LBL(caml_alloc2)
+ ret
CFI_ENDPROC
ENDFUNCTION(G(caml_alloc2))
FUNCTION(G(caml_alloc3))
CFI_STARTPROC
-LBL(caml_alloc3):
subq $32, %r15
cmpq Caml_state(young_limit), %r15
jb LBL(102)
ret
LBL(102):
- addq $32, %r15
RECORD_STACK_FRAME(0)
ENTER_FUNCTION
/* subq $8, %rsp; CFI_ADJUST (8) */
call LBL(caml_call_gc)
/* addq $8, %rsp; CFI_ADJUST (-8) */
LEAVE_FUNCTION
- jmp LBL(caml_alloc3)
+ ret
CFI_ENDPROC
ENDFUNCTION(G(caml_alloc3))
FUNCTION(G(caml_allocN))
CFI_STARTPROC
-LBL(caml_allocN):
- pushq %rax; CFI_ADJUST(8) /* save desired size */
subq %rax, %r15
cmpq Caml_state(young_limit), %r15
jb LBL(103)
- addq $8, %rsp; CFI_ADJUST (-8) /* drop desired size */
ret
LBL(103):
- addq 0(%rsp), %r15
- CFI_ADJUST(8)
- RECORD_STACK_FRAME(8)
-#ifdef WITH_FRAME_POINTERS
- /* ensure 16 byte alignment by subq + enter using 16-bytes, PR#7417 */
- subq $8, %rsp; CFI_ADJUST (8)
+ RECORD_STACK_FRAME(0)
ENTER_FUNCTION
-#endif
call LBL(caml_call_gc)
-#ifdef WITH_FRAME_POINTERS
- /* ensure 16 byte alignment by leave + addq using 16-bytes PR#7417 */
LEAVE_FUNCTION
- addq $8, %rsp; CFI_ADJUST (-8)
-#endif
- popq %rax; CFI_ADJUST(-8) /* recover desired size */
- jmp LBL(caml_allocN)
+ ret
CFI_ENDPROC
ENDFUNCTION(G(caml_allocN))
-
-/* Reset the allocation pointer and invoke the GC */
-
-FUNCTION(G(caml_call_gc1))
-CFI_STARTPROC
- addq $16, %r15
- jmp GCALL(caml_call_gc)
-CFI_ENDPROC
-
-FUNCTION(G(caml_call_gc2))
-CFI_STARTPROC
- addq $24, %r15
- jmp GCALL(caml_call_gc)
-CFI_ENDPROC
-
-FUNCTION(G(caml_call_gc3))
-CFI_STARTPROC
- addq $32, %r15
- jmp GCALL(caml_call_gc)
-CFI_ENDPROC
-
-
+
/* Call a C function from OCaml */
FUNCTION(G(caml_c_call))
diff --git a/runtime/backtrace_nat.c b/runtime/backtrace_nat.c
index acf31d644..ee18f2a00 100644
--- a/runtime/backtrace_nat.c
+++ b/runtime/backtrace_nat.c
@@ -146,8 +146,20 @@ debuginfo caml_debuginfo_extract(backtrace_slot slot)
}
/* Recover debugging info */
infoptr = (unsigned char*)&d->live_ofs[d->num_live];
- /* align to 32 bits */
- infoptr = Align_to(infoptr, uint32_t);
+ if (d->frame_size & 2) {
+ /* skip alloc_lengths */
+ infoptr += *infoptr + 1;
+ /* align to 32 bits */
+ infoptr = Align_to(infoptr, uint32_t);
+ /* we know there's at least one valid debuginfo,
+ but it may not be the one for the first alloc */
+ while (*(uint32_t*)infoptr == 0) {
+ infoptr += sizeof(uint32_t);
+ }
+ } else {
+ /* align to 32 bits */
+ infoptr = Align_to(infoptr, uint32_t);
+ }
/* read offset to debuginfo */
debuginfo_offset = *(uint32_t*)infoptr;
return (debuginfo)(infoptr + debuginfo_offset);
diff --git a/runtime/caml/stack.h b/runtime/caml/stack.h
index 30a18d274..44a881e41 100644
--- a/runtime/caml/stack.h
+++ b/runtime/caml/stack.h
@@ -89,9 +89,15 @@ typedef struct {
unsigned short num_live;
unsigned short live_ofs[1 /* num_live */];
/*
+ If frame_size & 2, then allocation info follows:
+ unsigned char num_allocs;
+ unsigned char alloc_lengths[num_alloc];
+
If frame_size & 1, then debug info follows:
- uint32_t debug_info_offset;
- Debug info is stored as a relative offset to a debuginfo structure. */
+ uint32_t debug_info_offset[num_debug];
+
+ Debug info is stored as relative offsets to debuginfo structures.
+ num_debug is num_alloc if frame_size & 2, otherwise 1. */
} frame_descr;
/* Used to compute offsets in frame tables.
diff --git a/runtime/minor_gc.c b/runtime/minor_gc.c
index e4dacfc51..4b3634275 100644
--- a/runtime/minor_gc.c
+++ b/runtime/minor_gc.c
@@ -509,6 +509,11 @@ void caml_alloc_small_dispatch (tag_t tag, intnat wosize, int flags)
callbacks. */
CAML_INSTR_INT ("force_minor/alloc_small@", 1);
caml_gc_dispatch ();
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+ if (caml_young_ptr == caml_young_alloc_end) {
+ caml_spacetime_automatic_snapshot();
+ }
+#endif
}
/* Re-do the allocation: we now have enough space in the minor heap. */
diff --git a/runtime/roots_nat.c b/runtime/roots_nat.c
index f61e56d90..b98555838 100644
--- a/runtime/roots_nat.c
+++ b/runtime/roots_nat.c
@@ -83,6 +83,11 @@ static frame_descr * next_frame_descr(frame_descr * d) {
CAMLassert(d->retaddr >= 4096);
/* Skip to end of live_ofs */
p = (unsigned char*)&d->live_ofs[d->num_live];
+ /* Skip alloc_lengths if present */
+ if (d->frame_size & 2) {
+ num_allocs = *p;
+ p += num_allocs + 1;
+ }
/* Skip debug info if present */
if (d->frame_size & 1) {
/* Align to 32 bits */
diff --git a/runtime/signals_nat.c b/runtime/signals_nat.c
index 017298394..075db46e3 100644
--- a/runtime/signals_nat.c
+++ b/runtime/signals_nat.c
@@ -69,29 +69,26 @@ extern char caml_system__code_begin, caml_system__code_end;
void caml_garbage_collection(void)
{
- /* TEMPORARY: if we have just sampled an allocation in native mode,
- we simply renew the sample to ignore it. Otherwise, renewing now
- will not have any effect on the sampling distribution, because of
- the memorylessness of the Bernoulli process.
-
- FIXME: if the sampling rate is 1, this leads to infinite loop,
- because we are using a binomial distribution in [memprof.c]. This
- will go away when the sampling of natively allocated blocks will
- be correctly implemented.
- */
- caml_memprof_renew_minor_sample();
- if (Caml_state->requested_major_slice || Caml_state->requested_minor_gc ||
- Caml_state->young_ptr - Caml_state->young_trigger < Max_young_whsize){
- caml_gc_dispatch ();
+ frame_descr* d;
+ uintnat h;
+ h = Hash_retaddr(Caml_state->last_return_address);
+ while (1) {
+ d = caml_frame_descriptors[h];
+ if (d->retaddr == Caml_state->last_return_address) break;
+ h = (h + 1) & caml_frame_descriptors_mask;
}
-#ifdef WITH_SPACETIME
- if (Caml_state->young_ptr == Caml_state->young_alloc_end) {
- caml_spacetime_automatic_snapshot();
- }
-#endif
+ /* Must be an allocation frame */
+ CAMLassert(d && d->frame_size != 0xFFFF && (d->frame_size & 2));
+
+ unsigned char* alloc_len = (unsigned char*)(&d->live_ofs[d->num_live]);
+ int nallocs = *alloc_len++;
+ int allocsz = 0;
+ for (int i = 0; i < nallocs; i++) allocsz += alloc_len[i] + 2;
+ allocsz -= 1;
- caml_raise_if_exception(caml_do_pending_actions_exn());
+ caml_alloc_small_dispatch(0 /* FIXME */, allocsz,
+ /* CAML_DO_TRACK | */ CAML_FROM_CAML);
}
DECLARE_SIGNAL_HANDLER(handle_signal)
--
2.24.1

926
0007-Use-allocation-size-info-on-more-than-just-amd64.patch Normal file
View File

@ -0,0 +1,926 @@
From 69eac75740fafad36246392c666410e9e66388d7 Mon Sep 17 00:00:00 2001
From: Stephen Dolan <sdolan@janestreet.com>
Date: Wed, 18 Sep 2019 16:15:18 +0100
Subject: [PATCH 7/8] Use allocation-size info on more than just amd64.
Moves the alloc_dbginfo type to Debuginfo, to avoid a circular
dependency on architectures that use Branch_relaxation.
This commit generates frame tables with allocation sizes on all
architectures, but does not yet update the allocation code for
non-amd64 backends.
(cherry picked from commit 768dcce48f79c33beb2af342a4c3551c276afe11)
---
.depend | 4 ++--
asmcomp/amd64/emit.mlp | 14 +++--------
asmcomp/arm/emit.mlp | 27 ++++++++++-----------
asmcomp/arm64/arch.ml | 3 ++-
asmcomp/arm64/emit.mlp | 37 +++++++++++++++--------------
asmcomp/branch_relaxation.ml | 5 ++--
asmcomp/branch_relaxation_intf.ml | 1 +
asmcomp/comballoc.ml | 6 ++---
asmcomp/emitaux.ml | 13 ++++++-----
asmcomp/emitaux.mli | 2 +-
asmcomp/i386/emit.mlp | 37 +++++++++++++++--------------
asmcomp/mach.ml | 6 +----
asmcomp/mach.mli | 11 +--------
asmcomp/power/arch.ml | 3 ++-
asmcomp/power/emit.mlp | 39 ++++++++++++++++---------------
asmcomp/s390x/emit.mlp | 25 ++++++++++----------
lambda/debuginfo.ml | 5 ++++
lambda/debuginfo.mli | 11 +++++++++
18 files changed, 128 insertions(+), 121 deletions(-)
diff --git a/.depend b/.depend
index c40e2f0f7..becb7bcc0 100644
--- a/.depend
+++ b/.depend
@@ -2152,10 +2152,12 @@ asmcomp/branch_relaxation.cmi : \
asmcomp/linear.cmi \
asmcomp/branch_relaxation_intf.cmo
asmcomp/branch_relaxation_intf.cmo : \
+ asmcomp/mach.cmi \
asmcomp/linear.cmi \
asmcomp/cmm.cmi \
asmcomp/arch.cmo
asmcomp/branch_relaxation_intf.cmx : \
+ asmcomp/mach.cmx \
asmcomp/linear.cmx \
asmcomp/cmm.cmx \
asmcomp/arch.cmx
@@ -2351,7 +2353,6 @@ asmcomp/emit.cmo : \
lambda/lambda.cmi \
asmcomp/emitaux.cmi \
utils/domainstate.cmi \
- lambda/debuginfo.cmi \
utils/config.cmi \
middle_end/compilenv.cmi \
asmcomp/cmm.cmi \
@@ -2373,7 +2374,6 @@ asmcomp/emit.cmx : \
lambda/lambda.cmx \
asmcomp/emitaux.cmx \
utils/domainstate.cmx \
- lambda/debuginfo.cmx \
utils/config.cmx \
middle_end/compilenv.cmx \
asmcomp/cmm.cmx \
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 6c3950a6d..bdf3462ec 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -281,8 +281,7 @@ let spacetime_before_uninstrumented_call ~node_ptr ~index =
(* Record calls to the GC -- we've moved them out of the way *)
type gc_call =
- { gc_size: int; (* Allocation size, in bytes *)
- gc_lbl: label; (* Entry label *)
+ { gc_lbl: label; (* Entry label *)
gc_return_lbl: label; (* Where to branch after GC *)
gc_frame: label; (* Label of frame descriptor *)
gc_spacetime : (X86_ast.arg * int) option;
@@ -662,10 +661,7 @@ let emit_instr fallthrough i =
I.movsd (arg i 0) (addressing addr REAL8 i 1)
end
| Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; dbginfo }) ->
- let dbginfo =
- if not !Clflags.debug && not Config.spacetime then
- List.map (fun d -> { d with alloc_dbg = Debuginfo.none }) dbginfo
- else dbginfo in
+ assert (n <= (Config.max_young_wosize + 1) * Arch.size_addr);
if !fastcode_flag then begin
I.sub (int n) r15;
I.cmp (domain_field Domainstate.Domain_young_limit) r15;
@@ -682,8 +678,7 @@ let emit_instr fallthrough i =
else Some (arg i 0, spacetime_index)
in
call_gc_sites :=
- { gc_size = n;
- gc_lbl = lbl_call_gc;
+ { gc_lbl = lbl_call_gc;
gc_return_lbl = lbl_after_alloc;
gc_frame = lbl_frame;
gc_spacetime; } :: !call_gc_sites
@@ -1009,9 +1004,6 @@ let begin_assembly() =
all_functions := [];
if system = S_win64 then begin
D.extrn "caml_call_gc" NEAR;
- D.extrn "caml_call_gc1" NEAR;
- D.extrn "caml_call_gc2" NEAR;
- D.extrn "caml_call_gc3" NEAR;
D.extrn "caml_c_call" NEAR;
D.extrn "caml_allocN" NEAR;
D.extrn "caml_alloc1" NEAR;
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index 1393d4576..0689cd17c 100644
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -105,7 +105,7 @@ let emit_addressing addr r n =
(* Record live pointers at call points *)
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -123,11 +123,11 @@ let record_frame_label ?label live raise_ dbg =
| _ -> ())
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
lbl
-let record_frame ?label live raise_ dbg =
- let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
+let record_frame ?label live dbg =
+ let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
(* Record calls to the GC -- we've moved them out of the way *)
@@ -155,7 +155,7 @@ 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
+ 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;
@@ -542,15 +542,15 @@ let emit_instr i =
| Lop(Icall_ind { label_after; }) ->
if !arch >= ARMv5 then begin
` blx {emit_reg i.arg.(0)}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
end else begin
` mov lr, pc\n`;
` bx {emit_reg i.arg.(0)}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`; 2
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 2
end
| Lop(Icall_imm { func; label_after; }) ->
` {emit_call func}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue begin fun () ->
if !contains_calls then
@@ -572,7 +572,7 @@ let emit_instr i =
| Lop(Iextcall { func; alloc = true; label_after; }) ->
let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
` {emit_call "caml_c_call"}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`;
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`;
1 + ninstr
| Lop(Istackoffset n) ->
assert (n mod 8 = 0);
@@ -642,9 +642,9 @@ let emit_instr i =
| Double_u -> "fstd"
| _ (* 32-bit quantities *) -> "str" in
` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
- | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
+ | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
let lbl_frame =
- record_frame_label i.live false i.dbg ?label:label_after_call_gc
+ record_frame_label i.live (Dbg_alloc dbginfo) ?label:label_after_call_gc
in
if !fastcode_flag then begin
let lbl_redo = new_label() in
@@ -912,10 +912,10 @@ let emit_instr i =
` mov r12, #0\n`;
` str r12, [domain_state_ptr, {emit_int offset}]\n`;
` {emit_call "caml_raise_exn"}\n`;
- `{record_frame Reg.Set.empty true i.dbg}\n`; 3
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`; 3
| Lambda.Raise_reraise ->
` {emit_call "caml_raise_exn"}\n`;
- `{record_frame Reg.Set.empty true i.dbg}\n`; 1
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`; 1
| Lambda.Raise_notrace ->
` mov sp, trap_ptr\n`;
` pop \{trap_ptr, pc}\n`; 2
@@ -1072,6 +1072,7 @@ let end_assembly () =
efa_data_label = (fun lbl ->
` .type {emit_label lbl}, %object\n`;
` .word {emit_label lbl}\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 -> ` .word {emit_int n}\n`);
diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml
index ce5902aa2..9cf923c6c 100644
--- a/asmcomp/arm64/arch.ml
+++ b/asmcomp/arm64/arch.ml
@@ -38,7 +38,8 @@ type cmm_label = int
(* Do not introduce a dependency to Cmm *)
type specific_operation =
- | Ifar_alloc of { bytes : int; label_after_call_gc : cmm_label option; }
+ | Ifar_alloc of { bytes : int; label_after_call_gc : cmm_label option;
+ dbginfo : Debuginfo.alloc_dbginfo }
| Ifar_intop_checkbound of { label_after_error : cmm_label option; }
| Ifar_intop_imm_checkbound of
{ bound : int; label_after_error : cmm_label option; }
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index eb8424bf5..cb5e75d7a 100644
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -126,7 +126,7 @@ let emit_addressing addr r =
(* Record live pointers at call points *)
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -144,11 +144,11 @@ let record_frame_label ?label live raise_ dbg =
| _ -> ())
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
lbl
-let record_frame ?label live raise_ dbg =
- let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
+let record_frame ?label live dbg =
+ let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
(* Record calls to the GC -- we've moved them out of the way *)
@@ -176,7 +176,7 @@ 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
+ 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;
@@ -512,8 +512,8 @@ module BR = Branch_relaxation.Make (struct
| Lambda.Raise_notrace -> 4
end
- let relax_allocation ~num_bytes ~label_after_call_gc =
- Lop (Ispecific (Ifar_alloc { bytes = num_bytes; label_after_call_gc; }))
+ let relax_allocation ~num_bytes ~label_after_call_gc ~dbginfo =
+ Lop (Ispecific (Ifar_alloc { bytes = num_bytes; label_after_call_gc; dbginfo }))
let relax_intop_checkbound ~label_after_error =
Lop (Ispecific (Ifar_intop_checkbound { label_after_error; }))
@@ -529,9 +529,9 @@ end)
(* Output the assembly code for allocation. *)
-let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
+let assembly_code_for_allocation ~label_after_call_gc i ~n ~far ~dbginfo =
let lbl_frame =
- record_frame_label ?label:label_after_call_gc i.live false i.dbg
+ record_frame_label ?label:label_after_call_gc i.live (Dbg_alloc dbginfo)
in
if !fastcode_flag then begin
let lbl_redo = new_label() in
@@ -626,10 +626,10 @@ let emit_instr i =
emit_load_symbol_addr i.res.(0) s
| Lop(Icall_ind { label_after; }) ->
` blr {emit_reg i.arg.(0)}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Icall_imm { func; label_after; }) ->
` bl {emit_symbol func}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`)
| Lop(Itailcall_imm { func; label_after = _; }) ->
@@ -642,7 +642,7 @@ let emit_instr i =
| Lop(Iextcall { func; alloc = true; label_after; }) ->
emit_load_symbol_addr reg_x15 func;
` bl {emit_symbol "caml_c_call"}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Istackoffset n) ->
assert (n mod 16 = 0);
emit_stack_adjustment (-n);
@@ -697,10 +697,10 @@ let emit_instr i =
| Word_int | Word_val | Double | Double_u ->
` str {emit_reg src}, {emit_addressing addr base}\n`
end
- | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
- assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc
- | Lop(Ispecific (Ifar_alloc { bytes = n; label_after_call_gc; })) ->
- assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc
+ | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
+ assembly_code_for_allocation i ~n ~far:false ~label_after_call_gc ~dbginfo
+ | Lop(Ispecific (Ifar_alloc { bytes = n; label_after_call_gc; dbginfo })) ->
+ assembly_code_for_allocation i ~n ~far:true ~label_after_call_gc ~dbginfo
| Lop(Iintop(Icomp cmp)) ->
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
@@ -906,10 +906,10 @@ let emit_instr i =
let offset = Domainstate.(idx_of_field Domain_backtrace_pos) * 8 in
` str xzr, [{emit_reg reg_domain_state_ptr}, {emit_int offset}]\n`;
` bl {emit_symbol "caml_raise_exn"}\n`;
- `{record_frame Reg.Set.empty true i.dbg}\n`
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`
| Lambda.Raise_reraise ->
` bl {emit_symbol "caml_raise_exn"}\n`;
- `{record_frame Reg.Set.empty true i.dbg}\n`
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`
| Lambda.Raise_notrace ->
` mov sp, {emit_reg reg_trap_ptr}\n`;
` ldr {emit_reg reg_tmp1}, [sp, #8]\n`;
@@ -1027,6 +1027,7 @@ let end_assembly () =
efa_data_label = (fun lbl ->
` .type {emit_label lbl}, %object\n`;
` .quad {emit_label lbl}\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`);
diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml
index 953c2827c..74b749ea8 100644
--- a/asmcomp/branch_relaxation.ml
+++ b/asmcomp/branch_relaxation.ml
@@ -86,8 +86,9 @@ module Make (T : Branch_relaxation_intf.S) = struct
fixup did_fix (pc + T.instr_size instr.desc) instr.next
else
match instr.desc with
- | Lop (Ialloc { bytes = num_bytes; label_after_call_gc; }) ->
- instr.desc <- T.relax_allocation ~num_bytes ~label_after_call_gc;
+ | Lop (Ialloc { bytes = num_bytes; label_after_call_gc; dbginfo }) ->
+ instr.desc <- T.relax_allocation ~num_bytes
+ ~dbginfo ~label_after_call_gc;
fixup true (pc + T.instr_size instr.desc) instr.next
| Lop (Iintop (Icheckbound { label_after_error; })) ->
instr.desc <- T.relax_intop_checkbound ~label_after_error;
diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml
index d5552f83f..b7a7271fb 100644
--- a/asmcomp/branch_relaxation_intf.ml
+++ b/asmcomp/branch_relaxation_intf.ml
@@ -63,6 +63,7 @@ module type S = sig
val relax_allocation
: num_bytes:int
-> label_after_call_gc:Cmm.label option
+ -> dbginfo:Debuginfo.alloc_dbginfo
-> Linear.instruction_desc
val relax_intop_checkbound
: label_after_error:Cmm.label option
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
index b8ebcf374..16bda3772 100644
--- a/asmcomp/comballoc.ml
+++ b/asmcomp/comballoc.ml
@@ -18,9 +18,9 @@
open Mach
type pending_alloc =
- { reg: Reg.t; (* register holding the result of the last allocation *)
- dbginfos: alloc_dbginfo list; (* debug info for each pending allocation *)
- totalsz: int } (* amount to be allocated in this block *)
+ { reg: Reg.t; (* register holding the result of the last allocation *)
+ dbginfos: Debuginfo.alloc_dbginfo; (* debug info for each pending alloc *)
+ totalsz: int } (* amount to be allocated in this block *)
type allocation_state =
No_alloc
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index 8ed63af28..8e3ec8d50 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -106,7 +106,7 @@ let emit_float32_directive directive x =
(* Record live pointers at call points *)
type frame_debuginfo =
- | Dbg_alloc of Mach.alloc_dbginfo list
+ | Dbg_alloc of Debuginfo.alloc_dbginfo
| Dbg_raise of Debuginfo.t
| Dbg_other of Debuginfo.t
@@ -175,9 +175,10 @@ let emit_frames a =
| Dbg_other d | Dbg_raise d ->
if Debuginfo.is_none d then 0 else 1
| Dbg_alloc dbgs ->
- if List.for_all (fun d ->
- Debuginfo.is_none d.Mach.alloc_dbg) dbgs
- then 2 else 3
+ if !Clflags.debug && not Config.spacetime &&
+ List.exists (fun d ->
+ not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
+ then 3 else 2
in
a.efa_code_label fd.fd_lbl;
a.efa_16 (fd.fd_frame_size + flags);
@@ -195,7 +196,7 @@ let emit_frames a =
| Dbg_alloc dbg ->
assert (List.length dbg < 256);
a.efa_8 (List.length dbg);
- List.iter (fun Mach.{alloc_words;_} ->
+ List.iter (fun Debuginfo.{alloc_words;_} ->
(* Possible allocations range between 2 and 257 *)
assert (2 <= alloc_words &&
alloc_words - 1 <= Config.max_young_wosize &&
@@ -203,7 +204,7 @@ let emit_frames a =
a.efa_8 (alloc_words - 2)) dbg;
if flags = 3 then begin
a.efa_align 4;
- List.iter (fun Mach.{alloc_dbg; _} ->
+ List.iter (fun Debuginfo.{alloc_dbg; _} ->
if Debuginfo.is_none alloc_dbg then
a.efa_32 Int32.zero
else
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index 1a8982a07..2b4867d0b 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -39,7 +39,7 @@ val emit_debug_info_gen :
(file_num:int -> line:int -> col:int -> unit) -> unit
type frame_debuginfo =
- | Dbg_alloc of Mach.alloc_dbginfo list
+ | Dbg_alloc of Debuginfo.alloc_dbginfo
| Dbg_raise of Debuginfo.t
| Dbg_other of Debuginfo.t
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 9c1ca30a2..614bb33fe 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -200,7 +200,7 @@ let addressing addr typ i n =
(* Record live pointers at call points *)
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -218,11 +218,11 @@ let record_frame_label ?label live raise_ dbg =
| _ -> ())
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
lbl
-let record_frame ?label live raise_ dbg =
- let lbl = record_frame_label ?label live raise_ dbg in
+let record_frame ?label live dbg =
+ let lbl = record_frame_label ?label live dbg in
def_label lbl
(* Record calls to the GC -- we've moved them out of the way *)
@@ -254,7 +254,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg =
if !Clflags.debug then begin
let lbl_bound_error = new_label() in
- let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg 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_frame } :: !bound_error_sites;
lbl_bound_error
@@ -540,11 +540,11 @@ let emit_instr fallthrough i =
I.mov (immsym s) (reg i.res.(0))
| Lop(Icall_ind { label_after; }) ->
I.call (reg i.arg.(0));
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| Lop(Icall_imm { func; label_after; }) ->
add_used_symbol func;
emit_call func;
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue begin fun () ->
I.jmp (reg i.arg.(0))
@@ -563,7 +563,7 @@ let emit_instr fallthrough i =
if alloc then begin
I.mov (immsym func) eax;
emit_call "caml_c_call";
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
end else begin
emit_call func
end
@@ -614,22 +614,24 @@ let emit_instr fallthrough i =
I.fstp (addressing addr REAL8 i 1)
end
end
- | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
+ | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
if !fastcode_flag then begin
- let lbl_redo = new_label() in
- def_label lbl_redo;
load_domain_state ebx;
I.mov (domain_field Domain_young_ptr RBX) eax;
I.sub (int n) eax;
I.cmp (domain_field Domain_young_limit RBX) eax;
let lbl_call_gc = new_label() in
- let lbl_frame = record_frame_label i.live false Debuginfo.none in
+ let lbl_frame =
+ record_frame_label ?label:label_after_call_gc
+ i.live (Dbg_alloc dbginfo) in
I.jb (label lbl_call_gc);
I.mov eax (domain_field Domain_young_ptr RBX);
+ let lbl_after_alloc = new_label() in
+ def_label lbl_after_alloc;
I.lea (mem32 NONE 4 RAX) (reg i.res.(0));
call_gc_sites :=
{ gc_lbl = lbl_call_gc;
- gc_return_lbl = lbl_redo;
+ gc_return_lbl = lbl_after_alloc;
gc_frame = lbl_frame } :: !call_gc_sites
end else begin
begin match n with
@@ -641,8 +643,8 @@ let emit_instr fallthrough i =
emit_call "caml_allocN"
end;
let label =
- record_frame_label ?label:label_after_call_gc i.live false
- Debuginfo.none
+ record_frame_label ?label:label_after_call_gc
+ i.live (Dbg_alloc dbginfo)
in
def_label label;
I.lea (mem32 NONE 4 RAX) (reg i.res.(0))
@@ -895,10 +897,10 @@ let emit_instr fallthrough i =
load_domain_state ebx;
I.mov (int 0) (domain_field Domain_backtrace_pos RBX);
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg
+ record_frame Reg.Set.empty (Dbg_raise i.dbg)
| Lambda.Raise_reraise ->
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg
+ record_frame Reg.Set.empty (Dbg_raise i.dbg)
| Lambda.Raise_notrace ->
load_domain_state ebx;
I.mov (domain_field Domain_exception_pointer RBX) esp;
@@ -1019,6 +1021,7 @@ let end_assembly() =
emit_frames
{ efa_code_label = (fun l -> D.long (ConstLabel (emit_label l)));
efa_data_label = (fun l -> D.long (ConstLabel (emit_label l)));
+ efa_8 = (fun n -> D.byte (const n));
efa_16 = (fun n -> D.word (const n));
efa_32 = (fun n -> D.long (const_32 n));
efa_word = (fun n -> D.long (const n));
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index 8df94d039..8518e9da6 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -39,10 +39,6 @@ type test =
| Ioddtest
| Ieventest
-type alloc_dbginfo =
- { alloc_words : int;
- alloc_dbg : Debuginfo.t }
-
type operation =
Imove
| Ispill
@@ -59,7 +55,7 @@ type operation =
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
| Ialloc of { bytes : int; label_after_call_gc : label option;
- dbginfo : alloc_dbginfo list; spacetime_index : int; }
+ dbginfo : Debuginfo.alloc_dbginfo; spacetime_index : int; }
| Iintop of integer_operation
| Iintop_imm of integer_operation * int
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index fd3e033bf..1141d57d0 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -46,15 +46,6 @@ type test =
| Ioddtest
| Ieventest
-type alloc_dbginfo =
- { alloc_words : int;
- alloc_dbg : Debuginfo.t }
-(** Due to Comballoc, a single Ialloc instruction may combine several
- unrelated allocations. Their Debuginfo.t (which may differ) are stored
- as a list of alloc_dbginfo. This list is in order of increasing memory
- address, which is the reverse of the original allocation order. Later
- allocations are consed to the front of this list by Comballoc. *)
-
type operation =
Imove
| Ispill
@@ -72,7 +63,7 @@ type operation =
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
(* false = initialization, true = assignment *)
| Ialloc of { bytes : int; label_after_call_gc : label option;
- dbginfo : alloc_dbginfo list; spacetime_index : int; }
+ dbginfo : Debuginfo.alloc_dbginfo; spacetime_index : int; }
(** For Spacetime only, Ialloc instructions take one argument, being the
pointer to the trie node for the current function. *)
| Iintop of integer_operation
diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml
index 70cd75ddb..11d9e2328 100644
--- a/asmcomp/power/arch.ml
+++ b/asmcomp/power/arch.ml
@@ -47,7 +47,8 @@ type specific_operation =
Imultaddf (* multiply and add *)
| Imultsubf (* multiply and subtract *)
| Ialloc_far of (* allocation in large functions *)
- { bytes : int; label_after_call_gc : int (*Cmm.label*) option; }
+ { bytes : int; label_after_call_gc : int (*Cmm.label*) option;
+ dbginfo : Debuginfo.alloc_dbginfo }
(* note: we avoid introducing a dependency to Cmm since this dep
is not detected when "make depend" is run under amd64 *)
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index 4c577d0b1..5053d2505 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -308,7 +308,7 @@ let adjust_stack_offset delta =
(* Record live pointers at call points *)
-let record_frame ?label live raise_ dbg =
+let record_frame ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -326,7 +326,7 @@ let record_frame ?label live raise_ dbg =
| _ -> ())
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
`{emit_label lbl}:\n`
(* Record floating-point literals (for PPC32) *)
@@ -546,8 +546,8 @@ module BR = Branch_relaxation.Make (struct
| Lpoptrap -> 2
| Lraise _ -> 6
- let relax_allocation ~num_bytes:bytes ~label_after_call_gc =
- Lop (Ispecific (Ialloc_far { bytes; label_after_call_gc; }))
+ let relax_allocation ~num_bytes:bytes ~label_after_call_gc ~dbginfo =
+ Lop (Ispecific (Ialloc_far { bytes; label_after_call_gc; dbginfo }))
(* [classify_addr], above, never identifies these instructions as needing
relaxing. As such, these functions should never be called. *)
@@ -652,26 +652,26 @@ let emit_instr i =
| ELF32 ->
` mtctr {emit_reg i.arg.(0)}\n`;
` bctrl\n`;
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| ELF64v1 ->
` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *)
` mtctr 0\n`;
` ld 2, 8({emit_reg i.arg.(0)})\n`; (* TOC for callee *)
` bctrl\n`;
- record_frame i.live false i.dbg ~label:label_after;
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after;
emit_reload_toc()
| ELF64v2 ->
` mtctr {emit_reg i.arg.(0)}\n`;
` mr 12, {emit_reg i.arg.(0)}\n`; (* addr of fn in r12 *)
` bctrl\n`;
- record_frame i.live false i.dbg ~label:label_after;
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after;
emit_reload_toc()
end
| Lop(Icall_imm { func; label_after; }) ->
begin match abi with
| ELF32 ->
emit_call func;
- record_frame i.live false i.dbg ~label:label_after
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after
| ELF64v1 | ELF64v2 ->
(* For PPC64, we cannot just emit a "bl s; nop" sequence, because
of the following scenario:
@@ -691,7 +691,7 @@ let emit_instr i =
Cost: 3 instructions if same TOC, 7 if different TOC.
Let's try option 2. *)
emit_call func;
- record_frame i.live false i.dbg ~label:label_after;
+ record_frame i.live (Dbg_other i.dbg) ~label:label_after;
` nop\n`;
emit_reload_toc()
end
@@ -751,11 +751,11 @@ let emit_instr i =
` addis 25, 0, {emit_upper emit_symbol func}\n`;
` addi 25, 25, {emit_lower emit_symbol func}\n`;
emit_call "caml_c_call";
- record_frame i.live false i.dbg
+ record_frame i.live (Dbg_other i.dbg)
| ELF64v1 | ELF64v2 ->
emit_tocload emit_gpr 25 (TocSym func);
emit_call "caml_c_call";
- record_frame i.live false i.dbg;
+ record_frame i.live (Dbg_other i.dbg);
` nop\n`
end
| Lop(Istackoffset n) ->
@@ -786,15 +786,15 @@ let emit_instr i =
| Single -> "stfs"
| Double | Double_u -> "stfd" in
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
- | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
+ | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
let call_gc_lbl = label_for_call_gc ?label_after_call_gc n in
` addi 31, 31, {emit_int(-n)}\n`;
` {emit_string cmplg} 31, 30\n`;
` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`;
` bltl {emit_label call_gc_lbl}\n`;
(* Exactly 4 instructions after the beginning of the alloc sequence *)
- record_frame i.live false Debuginfo.none
- | Lop(Ispecific(Ialloc_far { bytes = n; label_after_call_gc; })) ->
+ record_frame i.live (Dbg_alloc dbginfo)
+ | Lop(Ispecific(Ialloc_far { bytes = n; label_after_call_gc; dbginfo })) ->
let call_gc_lbl = label_for_call_gc ?label_after_call_gc n in
let lbl = new_label() in
` addi 31, 31, {emit_int(-n)}\n`;
@@ -802,7 +802,7 @@ let emit_instr i =
` bge {emit_label lbl}\n`;
` bl {emit_label call_gc_lbl}\n`;
(* Exactly 4 instructions after the beginning of the alloc sequence *)
- record_frame i.live false Debuginfo.none;
+ record_frame i.live (Dbg_alloc dbginfo);
`{emit_label lbl}: addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
| Lop(Iintop Isub) -> (* subfc has swapped arguments *)
` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
@@ -821,7 +821,7 @@ let emit_instr i =
end
| Lop(Iintop (Icheckbound { label_after_error; })) ->
if !Clflags.debug then
- record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
+ record_frame Reg.Set.empty (Dbg_other i.dbg) ?label:label_after_error;
` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
| Lop(Iintop op) ->
let instr = name_for_intop op in
@@ -839,7 +839,7 @@ let emit_instr i =
end
| Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
if !Clflags.debug then
- record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
+ record_frame Reg.Set.empty (Dbg_other i.dbg) ?label:label_after_error;
` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n`
| Lop(Iintop_imm(op, n)) ->
let instr = name_for_intop_imm op in
@@ -1023,11 +1023,11 @@ let emit_instr i =
| _ -> ` std 0, {emit_int (backtrace_pos * 8)}(28)\n`
end;
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg;
+ record_frame Reg.Set.empty (Dbg_raise i.dbg);
emit_call_nop()
| Lambda.Raise_reraise ->
emit_call "caml_raise_exn";
- record_frame Reg.Set.empty true i.dbg;
+ record_frame Reg.Set.empty (Dbg_raise i.dbg);
emit_call_nop()
| Lambda.Raise_notrace ->
` {emit_string lg} 0, {emit_int trap_handler_offset}(29)\n`;
@@ -1249,6 +1249,7 @@ let end_assembly() =
(fun l -> ` {emit_string datag} {emit_label l}\n`);
efa_data_label =
(fun l -> ` {emit_string datag} {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 -> ` {emit_string datag} {emit_int n}\n`);
diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
index 05070ec7c..ad3e09037 100644
--- a/asmcomp/s390x/emit.mlp
+++ b/asmcomp/s390x/emit.mlp
@@ -168,7 +168,7 @@ let emit_set_comp cmp res =
(* Record live pointers at call points *)
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
let lbl =
match label with
| None -> new_label()
@@ -186,11 +186,11 @@ let record_frame_label ?label live raise_ dbg =
| _ -> ())
live;
record_frame_descr ~label:lbl ~frame_size:(frame_size())
- ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+ ~live_offset:!live_offset dbg;
lbl
-let record_frame ?label live raise_ dbg =
- let lbl = record_frame_label ?label live raise_ dbg in
+let record_frame ?label live dbg =
+ let lbl = record_frame_label ?label live dbg in
`{emit_label lbl}:`
(* Record calls to caml_call_gc, emitted out of line. *)
@@ -218,7 +218,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg =
if !Clflags.debug then begin
let lbl_bound_error = new_label() in
- let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg 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_frame } :: !bound_error_sites;
lbl_bound_error
@@ -357,11 +357,11 @@ let emit_instr i =
emit_load_symbol_addr i.res.(0) s
| Lop(Icall_ind { label_after; }) ->
` basr %r14, {emit_reg i.arg.(0)}\n`;
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Icall_imm { func; label_after; }) ->
emit_call func;
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
| Lop(Itailcall_ind { label_after = _; }) ->
let n = frame_size() in
if !contains_calls then
@@ -387,7 +387,7 @@ let emit_instr i =
else begin
emit_load_symbol_addr reg_r7 func;
emit_call "caml_c_call";
- `{record_frame i.live false i.dbg ~label:label_after}\n`
+ `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
end
| Lop(Istackoffset n) ->
@@ -424,11 +424,11 @@ let emit_instr i =
| Double | Double_u -> "stdy" in
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
- | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
+ | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
let lbl_redo = new_label() in
let lbl_call_gc = new_label() in
let lbl_frame =
- record_frame_label i.live false i.dbg ?label:label_after_call_gc
+ record_frame_label i.live (Dbg_alloc dbginfo) ?label:label_after_call_gc
in
call_gc_sites :=
{ gc_lbl = lbl_call_gc;
@@ -641,10 +641,10 @@ let emit_instr i =
` lghi %r1, 0\n`;
` stg %r1, {emit_int offset}(%r10)\n`;
emit_call "caml_raise_exn";
- `{record_frame Reg.Set.empty true i.dbg}\n`
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`
| Lambda.Raise_reraise ->
emit_call "caml_raise_exn";
- `{record_frame Reg.Set.empty true i.dbg}\n`
+ `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`
| Lambda.Raise_notrace ->
` lg %r1, 0(%r13)\n`;
` lgr %r15, %r13\n`;
@@ -782,6 +782,7 @@ let end_assembly() =
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`);
diff --git a/lambda/debuginfo.ml b/lambda/debuginfo.ml
index 7a3390222..29c098f1e 100644
--- a/lambda/debuginfo.ml
+++ b/lambda/debuginfo.ml
@@ -29,6 +29,11 @@ type item = {
type t = item list
+type alloc_dbginfo_item =
+ { alloc_words : int;
+ alloc_dbg : t }
+type alloc_dbginfo = alloc_dbginfo_item list
+
let none = []
let is_none = function
diff --git a/lambda/debuginfo.mli b/lambda/debuginfo.mli
index 4dc5e5990..954a152dd 100644
--- a/lambda/debuginfo.mli
+++ b/lambda/debuginfo.mli
@@ -25,6 +25,17 @@ type item = private {
type t = item list
+type alloc_dbginfo_item =
+ { alloc_words : int;
+ alloc_dbg : t }
+(** Due to Comballoc, a single Ialloc instruction may combine several
+ unrelated allocations. Their Debuginfo.t (which may differ) are stored
+ as a list of alloc_dbginfo. This list is in order of increasing memory
+ address, which is the reverse of the original allocation order. Later
+ allocations are consed to the front of this list by Comballoc. *)
+
+type alloc_dbginfo = alloc_dbginfo_item list
+
val none : t
val is_none : t -> bool
--
2.24.1

1207
0005-Add-riscv64-backend.patch → 0008-Add-riscv64-backend.patch
View File

File diff suppressed because it is too large Load Diff

17
ocaml.spec
View File

@ -31,7 +31,7 @@
Name: ocaml
Version: 4.10.0
Release: 3%{?dist}
Release: 4%{?dist}
Summary: OCaml compiler and programming environment
@ -50,7 +50,7 @@ Source0: http://caml.inria.fr/pub/distrib/ocaml-4.10/ocaml-%{version}%{rc
#
# https://pagure.io/fedora-ocaml
#
# Current branch: fedora-32-4.10.0
# Current branch: fedora-33-4.10.0
#
# ALTERNATIVELY add a patch to the end of the list (leaving the
# existing patches unchanged) adding a comment to note that it should
@ -63,9 +63,13 @@ 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
# Out of tree patch for RISC-V support.
# https://github.com/nojb/riscv-ocaml
# Resets the version number back to 4.09.0.
Patch0005: 0005-Add-riscv64-backend.patch
# https://github.com/nojb/ocaml branch riscv
# I had to backport some other upstream patches from > 4.10 in
# order to get this to apply.
Patch0005: 0005-Use-a-more-compact-representation-of-debug-informati.patch
Patch0006: 0006-Retain-debug-information-about-allocation-sizes-for-.patch
Patch0007: 0007-Use-allocation-size-info-on-more-than-just-amd64.patch
Patch0008: 0008-Add-riscv64-backend.patch
BuildRequires: git
BuildRequires: gcc
@ -369,6 +373,9 @@ find $RPM_BUILD_ROOT \( -name '*.cmt' -o -name '*.cmti' \) -a -delete
%changelog
* Sat Apr 11 2020 Richard W.M. Jones <rjones@redhat.com> - 4.10.0-4.fc33
- Fix RISC-V backend.
* Thu Apr 02 2020 Richard W.M. Jones <rjones@redhat.com> - 4.10.0-3.fc33
- Update all OCaml dependencies for RPM 4.16.