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