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

Memprof: get precise callstacks when memory is allocated directly in the bytecode interpreter. 

This includes two changes: first, in bytegen.ml, we add a pseudo-event after every allocation or closure instruction. Second, in the interpreter, we save the current PC in the interpreter stack in [Setup_for_gc].
master
Jacques-Henri Jourdan 2020-01-15 00:26:54 +01:00
parent 09da7dd659
commit c4d7bcd352
13 changed files with 200 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Changes
View File

@ -29,7 +29,7 @@ Working version
### Code generation and optimizations:
- #8637, #8805: Record debug info for each allocation
- #8637, #8805, #9247: Record debug info for each allocation.
(Stephen Dolan and Jacques-Henri Jourdan, review by Damien Doligez,
KC Sivaramakrishnan and Xavier Leroy)

39
bytecomp/bytegen.ml
View File

@ -295,6 +295,31 @@ let add_event ev =
Kevent ev' :: cont -> weaken_event (merge_events ev ev') cont
| cont -> weaken_event ev cont
(* Pseudo events are ignored by the debugger. They are only used for
generating backtraces.
We prefer adding this event here rather than in lambda generation
1) there are many different situations where a Pmakeblock can
be generated
2) we prefer inserting a pseudo event rather than an event after
to prevent the debugger to stop at every single allocation. *)
let add_pseudo_event loc modname c =
if !Clflags.debug then
let ev =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = modname;
ev_loc = loc;
ev_kind = Event_pseudo;
ev_info = Event_other; (* Dummy *)
ev_typenv = Env.Env_empty; (* Dummy *)
ev_typsubst = Subst.identity; (* Dummy *)
ev_compenv = empty_env; (* Dummy *)
ev_stacksize = 0; (* Dummy *)
ev_repr = Event_none } (* Dummy *)
in
add_event ev c
else c
(**** Compilation of a lambda expression ****)
let try_blocks = ref [] (* list of stack size for each nested try block *)
@ -364,12 +389,10 @@ let comp_primitive p args =
Pgetglobal id -> Kgetglobal id
| Psetglobal id -> Ksetglobal id
| Pintcomp cmp -> Kintcomp cmp
| Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag)
| Pfield n -> Kgetfield n
| Pfield_computed -> Kgetvectitem
| Psetfield(n, _ptr, _init) -> Ksetfield n
| Psetfield_computed(_ptr, _init) -> Ksetvectitem
| Pfloatfield n -> Kgetfloatfield n
| Psetfloatfield (n, _init) -> Ksetfloatfield n
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
| Pccall p -> Kccall(p.prim_name, p.prim_arity)
@ -556,7 +579,8 @@ let rec comp_expr env exp sz cont =
comp_args env args' (sz + 3)
(getmethod :: Kapply nargs :: cont1)
end
| Lfunction{params; body} -> (* assume kind = Curried *)
| Lfunction{params; body; loc} -> (* assume kind = Curried *)
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 =
@ -706,7 +730,8 @@ let rec comp_expr env exp sz cont =
(Kpush::
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim(Pmakearray (kind, _), args, _) ->
| Lprim(Pmakearray (kind, _), args, loc) ->
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)
@ -750,6 +775,12 @@ let rec comp_expr env exp sz cont =
| CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
in
comp_args env args sz cont
| Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
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 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)
| Lstaticcatch (body, (i, vars) , handler) ->

8
runtime/interp.c
View File

@ -71,9 +71,10 @@ sp is a local copy of the global variable Caml_state->extern_sp. */
// Do call asynchronous callbacks from allocation functions
#define Alloc_small_origin CAML_FROM_CAML
#define Setup_for_gc \
{ sp -= 2; sp[0] = accu; sp[1] = env; Caml_state->extern_sp = sp; }
{ sp -= 3; sp[0] = accu; sp[1] = env; sp[2] = (value)pc; \
Caml_state->extern_sp = sp; }
#define Restore_after_gc \
{ sp = Caml_state->extern_sp; accu = sp[0]; env = sp[1]; sp += 2; }
{ sp = Caml_state->extern_sp; accu = sp[0]; env = sp[1]; sp += 3; }
/* We store [pc+1] in the stack so that, in case of an exception, the
first backtrace slot points to the event following the C call
@ -746,10 +747,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
Instruct(GETFIELD):
accu = Field(accu, *pc); pc++; Next;
Instruct(GETFLOATFIELD): {
double d = Double_flat_field(accu, *pc);
double d = Double_flat_field(accu, *pc++);
Alloc_small(accu, Double_wosize, Double_tag);
Store_double_val(accu, d);
pc++;
Next;
}

17
testsuite/tests/statmemprof/arrays_in_major.ml
View File

@ -139,22 +139,5 @@ let () =
check_distrib 300 300 100000 0.1;
check_distrib 300000 300000 30 0.1
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start ~callstack_size:10
~major_alloc_callback:(fun info ->
callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_arrays 300 300 100 false;
stop ();
match !callstack with
| None -> assert false
| Some cs -> Printexc.print_raw_backtrace stdout cs
let () = check_callstack ()
let () =
Printf.printf "OK !\n"

4
testsuite/tests/statmemprof/arrays_in_major.reference
View File

@ -8,8 +8,4 @@ check_distrib 300 3000 1 0.010000
check_distrib 300 3000 1 0.900000
check_distrib 300 300 100000 0.100000
check_distrib 300000 300000 30 0.100000
check_callstack
Raised by primitive operation at file "arrays_in_major.ml", line 13, characters 14-28
Called from file "arrays_in_major.ml", line 151, characters 2-35
Called from file "arrays_in_major.ml", line 157, characters 9-27
OK !

17
testsuite/tests/statmemprof/arrays_in_minor.ml
View File

@ -149,22 +149,5 @@ let () =
check_distrib 1 1 10000000 0.01;
check_distrib 250 250 100000 0.1
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if info.size > 100 then callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_arrays 250 250 100 false;
stop ();
match !callstack with
| None -> assert false
| Some cs -> Printexc.print_raw_backtrace stdout cs
let () = check_callstack ()
let () =
Printf.printf "OK !\n"

4
testsuite/tests/statmemprof/arrays_in_minor.reference
View File

@ -8,8 +8,4 @@ check_distrib 1 250 1000 0.010000
check_distrib 1 250 1000 0.900000
check_distrib 1 1 10000000 0.010000
check_distrib 250 250 100000 0.100000
check_callstack
Raised by primitive operation at file "arrays_in_minor.ml", line 21, characters 15-31
Called from file "arrays_in_minor.ml", line 161, characters 2-35
Called from file "arrays_in_minor.ml", line 167, characters 9-27
OK !

88
testsuite/tests/statmemprof/callstacks.ml Normal file
View File

@ -0,0 +1,88 @@
(* TEST
flags = "-g -w -5"
* bytecode
*)
open Gc.Memprof
let alloc_list_literal () =
ignore (Sys.opaque_identity [Sys.opaque_identity 1])
let alloc_pair () =
ignore (Sys.opaque_identity (Sys.opaque_identity 1, Sys.opaque_identity 2))
type record = { a : int; b : int }
let alloc_record () =
ignore (Sys.opaque_identity
{a = Sys.opaque_identity 1; b = Sys.opaque_identity 2})
let alloc_some () =
ignore (Sys.opaque_identity (Some (Sys.opaque_identity 2)))
let alloc_array_literal () =
ignore (Sys.opaque_identity [|Sys.opaque_identity 1|])
let alloc_float_array_literal () =
ignore (Sys.opaque_identity
[|Sys.opaque_identity 1.; Sys.opaque_identity 2.|])
let[@inline never] do_alloc_unknown_array_literal x =
Sys.opaque_identity [|x|]
let alloc_unknown_array_literal () =
ignore (Sys.opaque_identity (do_alloc_unknown_array_literal 1.))
let alloc_small_array () =
ignore (Sys.opaque_identity (Array.make 10 (Sys.opaque_identity 1)))
let alloc_large_array () =
ignore (Sys.opaque_identity (Array.make 100000 (Sys.opaque_identity 1)))
let alloc_closure () =
let x = Sys.opaque_identity 1 in
ignore (Sys.opaque_identity (fun () -> x))
let floatarray = [| 1. |]
let getfloatfield () =
ignore (Sys.opaque_identity (floatarray.(0)))
let marshalled =
Marshal.to_string [Sys.opaque_identity 1] []
let alloc_unmarshal () =
ignore (Sys.opaque_identity
(Marshal.from_string (Sys.opaque_identity marshalled) 0))
let alloc_ref () =
ignore (Sys.opaque_identity (ref (Sys.opaque_identity 1)))
let fl = 1.
let alloc_boxedfloat () =
ignore (Sys.opaque_identity
(Sys.opaque_identity fl *. Sys.opaque_identity fl))
let allocators =
[alloc_list_literal; alloc_pair; alloc_record; alloc_some;
alloc_array_literal; alloc_float_array_literal; alloc_unknown_array_literal;
alloc_small_array; alloc_large_array; alloc_closure;
getfloatfield; alloc_unmarshal; alloc_ref; alloc_boxedfloat]
let test alloc =
Printf.printf "-----------\n%!";
let callstack = ref None in
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
callstack := Some info.callstack;
None
)
~major_alloc_callback:(fun info ->
callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
alloc ();
stop ();
match !callstack with
| None -> assert false
| Some cs -> Printexc.print_raw_backtrace stdout cs
let () =
List.iter test allocators

72
testsuite/tests/statmemprof/callstacks.reference Normal file
View File

@ -0,0 +1,72 @@
-----------
Raised by primitive operation at file "callstacks.ml", line 9, characters 30-53
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 12, characters 30-76
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 17, characters 12-66
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 20, characters 30-60
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 23, characters 30-55
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 27, characters 12-62
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 30, characters 22-27
Called from file "callstacks.ml", line 32, characters 30-65
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 35, characters 30-69
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 38, characters 30-73
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 42, characters 30-43
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 46, characters 30-46
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "marshal.ml", line 61, characters 9-35
Called from file "callstacks.ml", line 52, characters 12-68
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 55, characters 30-59
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27
-----------
Raised by primitive operation at file "callstacks.ml", line 60, characters 12-62
Called from file "callstacks.ml", line 81, characters 2-10
Called from file "list.ml", line 110, characters 12-15
Called from file "callstacks.ml", line 88, characters 2-27

24
testsuite/tests/statmemprof/intern.ml
View File

@ -162,29 +162,5 @@ let () =
check_distrib 2 2000 1 0.9;
check_distrib 300000 300000 20 0.1
(* FIXME : in bytecode mode, C calls may or may not be associated with
debug information. In particular, C calls at tail positions do not
have debug information, and the [from_bytes_unsafe] external C
function is called at tail positionin [marshal.ml]. This is the
reason why the reference file is different in native and bytecode
modes. *)
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
precompute_marshalled_data 2 300;
let callstack = ref None in
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if info.unmarshalled then callstack := Some info.callstack;
None)
~sampling_rate:1. ();
do_intern 2 250 1 false;
stop ();
match !callstack with
| None -> assert false
| Some cs -> Printexc.print_raw_backtrace stdout cs
let () = check_callstack ()
let () =
Printf.printf "OK !\n"

5
testsuite/tests/statmemprof/intern.reference
View File

@ -7,9 +7,4 @@ check_distrib 2 3000 1 0.000100
check_distrib 2 2000 1 0.010000
check_distrib 2 2000 1 0.900000
check_distrib 300000 300000 20 0.100000
check_callstack
Raised by primitive operation at file "marshal.ml", line 61, characters 9-35
Called from file "intern.ml", line 30, characters 14-35
Called from file "intern.ml", line 181, characters 2-25
Called from file "intern.ml", line 187, characters 9-27
OK !

19
testsuite/tests/statmemprof/lists_in_minor.ml
View File

@ -53,24 +53,5 @@ let () =
check_distrib 100000 10 0.1;
check_distrib 100000 10 0.9
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
assert (info.size = 2);
callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_lists 1000000 1;
stop ();
match !callstack with
| None -> assert false
| Some cs -> Printexc.print_raw_backtrace stdout cs
let () =
check_callstack ()
let () =
Printf.printf "OK !\n"

4
testsuite/tests/statmemprof/lists_in_minor.reference
View File

@ -5,8 +5,4 @@ check_distrib 1000000 10 0.001000
check_distrib 1000000 10 0.010000
check_distrib 100000 10 0.100000
check_distrib 100000 10 0.900000
check_callstack
Raised by primitive operation at file "lists_in_minor.ml", line 14, characters 11-33
Called from file "lists_in_minor.ml", line 66, characters 2-26
Called from file "lists_in_minor.ml", line 73, characters 2-20
OK !