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

Print function names (derived from Lambda.scoped_location) in backtraces 

Function names now appear in backtraces and are available via Printexc.
master
Stephen Dolan 2019-11-20 15:48:10 +00:00
parent 2986beaa78
commit 0040c5d783
10 changed files with 97 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
asmcomp/emitaux.ml
View File

@ -147,6 +147,16 @@ let emit_frames a =
Hashtbl.add filenames name lbl;
lbl
in
let defnames = Hashtbl.create 7 in
let label_defname filename defname =
try
snd (Hashtbl.find defnames (filename, defname))
with Not_found ->
let file_lbl = label_filename filename in
let def_lbl = Cmm.new_label () in
Hashtbl.add defnames (filename, defname) (file_lbl, def_lbl);
def_lbl
in
let module Label_table =
Hashtbl.Make (struct
type t = bool * Debuginfo.t
@ -215,8 +225,16 @@ let emit_frames a =
in
let emit_filename name lbl =
a.efa_def_label lbl;
a.efa_string name;
a.efa_align Arch.size_addr
a.efa_string name
in
let emit_defname (_filename, defname) (file_lbl, lbl) =
(* These must be 32-bit aligned, both because they contain a
32-bit value, and because emit_debuginfo assumes the low 2 bits
of their addresses are 0. *)
a.efa_align 4;
a.efa_def_label lbl;
a.efa_label_rel file_lbl 0l;
a.efa_string defname
in
let pack_info fd_raise d has_next =
let line = min 0xFFFFF d.Debuginfo.dinfo_line
@ -234,12 +252,14 @@ let emit_frames a =
(* 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_align 4;
a.efa_def_label lbl;
let rec emit rs d rest =
let open Debuginfo in
let info = pack_info rs d (rest <> []) in
let defname = Scoped_location.string_of_scopes d.dinfo_scopes in
a.efa_label_rel
(label_filename d.Debuginfo.dinfo_file)
(label_defname d.dinfo_file defname)
(Int64.to_int32 info);
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
match rest with
@ -252,6 +272,8 @@ let emit_frames a =
List.iter emit_frame !frame_descriptors;
Label_table.iter emit_debuginfo debuginfos;
Hashtbl.iter emit_filename filenames;
Hashtbl.iter emit_defname defnames;
a.efa_align Arch.size_addr;
frame_descriptors := []
(* Detection of functions that can be duplicated between a DLL and

28
bytecomp/bytegen.ml
View File

@ -22,6 +22,7 @@ open Types
open Lambda
open Switch
open Instruct
open Debuginfo.Scoped_location
(**** Label generation ****)
@ -228,15 +229,10 @@ let rec size_of_lambda env = function
(**** Merging consecutive events ****)
let copy_event ev kind info repr =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = ev.ev_module;
ev_loc = ev.ev_loc;
{ ev with
ev_pos = 0; (* patched in emitcode *)
ev_kind = kind;
ev_info = info;
ev_typenv = ev.ev_typenv;
ev_typsubst = ev.ev_typsubst;
ev_compenv = ev.ev_compenv;
ev_stacksize = ev.ev_stacksize;
ev_repr = repr }
let merge_infos ev ev' =
@ -306,10 +302,12 @@ let add_event ev =
to prevent the debugger to stop at every single allocation. *)
let add_pseudo_event loc modname c =
if !Clflags.debug then
let ev_defname = string_of_scoped_location loc in
let ev =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = modname;
ev_loc = loc;
ev_loc = to_location loc;
ev_defname;
ev_kind = Event_pseudo;
ev_info = Event_other; (* Dummy *)
ev_typenv = Env.Env_empty; (* Dummy *)
@ -584,7 +582,7 @@ let rec comp_expr env exp sz cont =
(getmethod :: Kapply nargs :: cont1)
end
| Lfunction{params; body; loc} -> (* assume kind = Curried *)
let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
let cont = add_pseudo_event loc !compunit_name cont in
let lbl = new_label() in
let fv = Ident.Set.elements(free_variables exp) in
let to_compile =
@ -735,7 +733,7 @@ let rec comp_expr env exp sz cont =
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim(Pmakearray (kind, _), args, loc) ->
let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
let cont = add_pseudo_event loc !compunit_name cont in
begin match kind with
Pintarray | Paddrarray ->
comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
@ -780,10 +778,10 @@ let rec comp_expr env exp sz cont =
in
comp_args env args sz cont
| Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
let cont = add_pseudo_event loc !compunit_name cont in
comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
| Lprim(Pfloatfield n, args, loc) ->
let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
let cont = add_pseudo_event loc !compunit_name cont in
comp_args env args sz (Kgetfloatfield n :: cont)
| Lprim(p, args, _) ->
comp_args env args sz (comp_primitive p args :: cont)
@ -922,11 +920,15 @@ let rec comp_expr env exp sz cont =
fatal_error "Bytegen.comp_expr: assign"
end
| Levent(lam, lev) ->
let ev_defname = match lev.lev_loc with
| Loc_unknown -> "??"
| Loc_known { loc = _; scopes } -> string_of_scopes scopes in
let event kind info =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = !compunit_name;
ev_loc = raw_location lev.lev_loc;
ev_loc = to_location lev.lev_loc;
ev_kind = kind;
ev_defname;
ev_info = info;
ev_typenv = Env.summary lev.lev_env;
ev_typsubst = Subst.identity;

1
bytecomp/instruct.ml
View File

@ -25,6 +25,7 @@ type debug_event =
ev_module: string; (* Name of defining module *)
ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_defname: string; (* Enclosing definition *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
ev_typsubst: Subst.t; (* Substitution over types *)

3
bytecomp/instruct.mli
View File

@ -37,12 +37,13 @@ type compilation_env =
(* Debugging events *)
(* Warning: when you change these types, check runtime/backtrace.c *)
(* Warning: when you change these types, check runtime/backtrace_byt.c *)
type debug_event =
{ mutable ev_pos: int; (* Position in bytecode *)
ev_module: string; (* Name of defining module *)
ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_defname: string; (* Enclosing definition *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
ev_typsubst: Subst.t; (* Substitution over types *)

10
runtime/backtrace.c
View File

@ -93,8 +93,8 @@ static void print_location(struct caml_loc_info * li, int index)
if (! li->loc_valid) {
fprintf(stderr, "%s unknown location%s\n", info, inlined);
} else {
fprintf (stderr, "%s file \"%s\"%s, line %d, characters %d-%d\n",
info, li->loc_filename, inlined, li->loc_lnum,
fprintf (stderr, "%s %s in file \"%s\"%s, line %d, characters %d-%d\n",
info, li->loc_defname, li->loc_filename, inlined, li->loc_lnum,
li->loc_startchr, li->loc_endchr);
}
}
@ -188,20 +188,22 @@ CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace)
static value caml_convert_debuginfo(debuginfo dbg)
{
CAMLparam0();
CAMLlocal2(p, fname);
CAMLlocal3(p, fname, dname);
struct caml_loc_info li;
caml_debuginfo_location(dbg, &li);
if (li.loc_valid) {
fname = caml_copy_string(li.loc_filename);
p = caml_alloc_small(6, 0);
dname = caml_copy_string(li.loc_defname);
p = caml_alloc_small(7, 0);
Field(p, 0) = Val_bool(li.loc_is_raise);
Field(p, 1) = fname;
Field(p, 2) = Val_int(li.loc_lnum);
Field(p, 3) = Val_int(li.loc_startchr);
Field(p, 4) = Val_int(li.loc_endchr);
Field(p, 5) = Val_bool(li.loc_is_inlined);
Field(p, 6) = dname;
} else {
p = caml_alloc_small(1, 1);
Field(p, 0) = Val_bool(li.loc_is_raise);

15
runtime/backtrace_byt.c
View File

@ -54,7 +54,8 @@ enum {
EV_POS = 0,
EV_MODULE = 1,
EV_LOC = 2,
EV_KIND = 3
EV_KIND = 3,
EV_DEFNAME = 4
};
/* Location of fields in the Location.t record. */
@ -77,6 +78,7 @@ enum {
struct ev_info {
code_t ev_pc;
char *ev_filename;
char *ev_defname;
int ev_lnum;
int ev_startchr;
int ev_endchr;
@ -176,6 +178,16 @@ static struct ev_info *process_debug_events(code_t code_start,
caml_fatal_error ("caml_add_debug_info: out of memory");
}
if (Is_block(Field(ev, EV_DEFNAME)) &&
Tag_val(Field(ev, EV_DEFNAME)) == String_tag) {
const char *dname = String_val(Field(ev, EV_DEFNAME));
events[j].ev_defname = caml_stat_strdup_noexc(dname);
if (events[j].ev_defname == NULL)
caml_fatal_error ("caml_add_debug_info: out of memory");
} else {
events[j].ev_defname = "<old bytecode>";
}
events[j].ev_lnum = Int_val(Field(ev_start, POS_LNUM));
events[j].ev_startchr =
Int_val(Field(ev_start, POS_CNUM))
@ -461,6 +473,7 @@ void caml_debuginfo_location(debuginfo dbg,
li->loc_valid = 1;
li->loc_is_inlined = 0;
li->loc_filename = event->ev_filename;
li->loc_defname = event->ev_defname;
li->loc_lnum = event->ev_lnum;
li->loc_startchr = event->ev_startchr;
li->loc_endchr = event->ev_endchr;

13
runtime/backtrace_nat.c
View File

@ -231,10 +231,18 @@ debuginfo caml_debuginfo_next(debuginfo dbg)
return (debuginfo*)(infoptr + 2);
}
/* Multiple names may share the same filename,
so it is referenced as an offset instead of stored inline */
struct name_info {
int32_t filename_offs;
char name[1];
};
/* Extract location information for the given frame descriptor */
void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
{
uint32_t info1, info2;
struct name_info * name_info;
/* If no debugging information available, print nothing.
When everything is compiled with -g, this corresponds to
@ -248,6 +256,7 @@ void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
/* Recover debugging info */
info1 = ((uint32_t *)dbg)[0];
info2 = ((uint32_t *)dbg)[1];
name_info = (struct name_info*)((char *) dbg + (info1 & 0x3FFFFFC));
/* Format of the two info words:
llllllllllllllllllll aaaaaaaa bbbbbbbbbb ffffffffffffffffffffffff k n
44 36 26 2 1 0
@ -263,7 +272,9 @@ void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
li->loc_valid = 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_defname = name_info->name;
li->loc_filename =
(char *)name_info + name_info->filename_offs;
li->loc_lnum = info2 >> 12;
li->loc_startchr = (info2 >> 4) & 0xFF;
li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);

1
runtime/caml/backtrace_prim.h
View File

@ -36,6 +36,7 @@ struct caml_loc_info {
int loc_valid;
int loc_is_raise;
char * loc_filename;
char * loc_defname;
int loc_lnum;
int loc_startchr;
int loc_endchr;

13
stdlib/printexc.ml
View File

@ -108,6 +108,7 @@ type backtrace_slot =
start_char : int;
end_char : int;
is_inline : bool;
defname : string;
}
| Unknown_location of {
is_raise : bool
@ -116,7 +117,7 @@ type backtrace_slot =
(* to avoid warning *)
let _ = [Known_location { is_raise = false; filename = "";
line_number = 0; start_char = 0; end_char = 0;
is_inline = false };
is_inline = false; defname = "" };
Unknown_location { is_raise = false }]
external convert_raw_backtrace_slot:
@ -143,8 +144,8 @@ let format_backtrace_slot pos slot =
else
Some (sprintf "%s unknown location" (info false))
| Known_location l ->
Some (sprintf "%s file \"%s\"%s, line %d, characters %d-%d"
(info l.is_raise) l.filename
Some (sprintf "%s %s in file \"%s\"%s, line %d, characters %d-%d"
(info l.is_raise) l.defname l.filename
(if l.is_inline then " (inlined)" else "")
l.line_number l.start_char l.end_char)
@ -208,6 +209,11 @@ let backtrace_slot_location = function
end_char = l.end_char;
}
let backtrace_slot_defname = function
| Unknown_location _
| Known_location { defname = "" } -> None
| Known_location l -> Some l.defname
let backtrace_slots raw_backtrace =
(* The documentation of this function guarantees that Some is
returned only if a part of the trace is usable. This gives us
@ -234,6 +240,7 @@ module Slot = struct
let is_raise = backtrace_slot_is_raise
let is_inline = backtrace_slot_is_inline
let location = backtrace_slot_location
let name = backtrace_slot_defname
end
external raw_backtrace_length :

10
stdlib/printexc.mli
View File

@ -269,6 +269,16 @@ module Slot : sig
@since 4.02
*)
val name : t -> string option
(** [name slot] returns the name of the function or definition
enclosing the location referred to by the slot.
[name slot] returns None if the name is unavailable, which
may happen for the same reasons as [location] returning None.
@since 4.11
*)
val format : int -> t -> string option
(** [format pos slot] returns the string representation of [slot] as
[raw_backtrace_to_string] would format it, assuming it is the