Memprof: report different callstacks for different combined allocations.

runtime/backtrace.c

@@ -330,7 +330,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) {
   CAMLlocal1(res);
 
   res = caml_alloc(caml_current_callstack_size(Long_val(max_frames_value)), 0);
-  caml_current_callstack_write(res);
+  caml_current_callstack_write(res, 0);
 
   CAMLreturn(res);
 }

runtime/backtrace_byt.c

@@ -284,10 +284,12 @@ intnat caml_current_callstack_size(intnat max_frames)
   return trace_size;
 }
 
-void caml_current_callstack_write(value trace) {
+void caml_current_callstack_write(value trace, unsigned alloc_idx)
+{
   value * sp = Caml_state->extern_sp;
   value * trsp = Caml_state->trapsp;
   uintnat trace_pos, trace_size = Wosize_val(trace);
+  CAMLassert(alloc_idx == 0);
 
   for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
     code_t p = caml_next_frame_pointer(&sp, &trsp);

runtime/backtrace_nat.c

@@ -121,12 +121,23 @@ intnat caml_current_callstack_size(intnat max_frames) {
   return trace_size;
 }
 
-void caml_current_callstack_write(value trace) {
+static debuginfo debuginfo_extract(frame_descr* d, unsigned alloc_idx);
+void caml_current_callstack_write(value trace, unsigned alloc_idx)
+{
   uintnat pc = Caml_state->last_return_address;
   char * sp = Caml_state->bottom_of_stack;
-  intnat trace_pos, trace_size = Wosize_val(trace);
+  intnat trace_pos = 0, trace_size = Wosize_val(trace);
+
+  if (alloc_idx > 0 && trace_size > 0) {
+    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+    debuginfo info = debuginfo_extract(descr, alloc_idx);
+    /* Mark this debuginfo as already extracted */
+    backtrace_slot slot = (backtrace_slot)((uintnat)info + 2);
+    Field(trace, 0) = Val_backtrace_slot(slot);
+    trace_pos++;
+  }
 
-  for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+  for (; trace_pos < trace_size; trace_pos++) {
     frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
     CAMLassert(descr != NULL);
     /* [Val_backtrace_slot(...)] is always a long, no need to call
@@ -135,36 +146,56 @@ void caml_current_callstack_write(value trace) {
   }
 }
 
-debuginfo caml_debuginfo_extract(backtrace_slot slot)
+static debuginfo debuginfo_extract(frame_descr* d, unsigned alloc_idx)
 {
   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 = (unsigned char*)&d->live_ofs[d->num_live];
   if (d->frame_size & 2) {
+    CAMLassert(alloc_idx < *infoptr);
     /* 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);
+    /* select the right debug info for this allocation */
+    infoptr += alloc_idx * sizeof(uint32_t);
+    if (alloc_idx == 0 && *(uint32_t*)infoptr == 0) {
+      /* Special case: if we're asked for index 0 and index 0 doesn't
+         have debug info, return the first debug info we can find.
+         This occurs when we're generating a backtrace through a
+         finaliser/signal handler triggered via a Comballoc
+         allocation, at which point it doesn't matter which allocation
+         we report debug info for */
+      infoptr -= alloc_idx * sizeof(uint32_t);
+      while (*(uint32_t*)infoptr == 0) {
+        infoptr += sizeof(uint32_t);
+      }
     }
   } else {
     /* align to 32 bits */
     infoptr = Align_to(infoptr, uint32_t);
+    CAMLassert(alloc_idx == 0);
   }
-  /* read offset to debuginfo */
   debuginfo_offset = *(uint32_t*)infoptr;
+  CAMLassert(debuginfo_offset != 0 && (debuginfo_offset & 3) == 0);
   return (debuginfo)(infoptr + debuginfo_offset);
 }
 
+debuginfo caml_debuginfo_extract(backtrace_slot slot)
+{
+  if ((uintnat)slot & 2) {
+    /* already a decoded debuginfo */
+    return (debuginfo)((uintnat)slot - 2);
+  } else {
+    return debuginfo_extract((frame_descr*)slot, 0);
+  }
+}
+
 debuginfo caml_debuginfo_next(debuginfo dbg)
 {
   uint32_t * infoptr;

runtime/caml/backtrace_prim.h

@@ -111,7 +111,7 @@ value caml_remove_debug_info(code_t start);
  * `max_int` from the OCaml side would overflow on 64bits machines. */
 
 intnat caml_current_callstack_size(intnat max_frames);
-void caml_current_callstack_write(value trace);
+void caml_current_callstack_write(value trace, unsigned alloc_idx);
 
 #endif /* CAML_INTERNALS */
 

runtime/caml/misc.h

@@ -539,8 +539,10 @@ int caml_find_code_fragment(char *pc, int *index, struct code_fragment **cf);
 
 /* The [backtrace_slot] type represents values stored in
  * [Caml_state->backtrace_buffer].  In bytecode, it is the same as a
- * [code_t], in native code it as a [frame_descr *].  The difference
- * doesn't matter for code outside [backtrace_{byt,nat}.c],
+ * [code_t], in native code it is either a [frame_descr *] or a [debuginfo],
+ * depending on the second-lowest bit.  In any case, the lowest bit must
+ * be 0.
+ * The representation doesn't matter for code outside [backtrace_{byt,nat}.c],
  * so it is just exposed as a [void *].
  */
 typedef void * backtrace_slot;

runtime/memprof.c

@@ -144,27 +144,27 @@ static uintnat mt_generate_binom(uintnat len)
    which may call the GC, but prefer using [caml_alloc_shr], which
    gives this guarantee. The return value is either a valid callstack
    or 0 in out-of-memory scenarios. */
-static value capture_callstack_postponed(void)
+static value capture_callstack_postponed(unsigned alloc_idx)
 {
   value res;
   uintnat wosize = caml_current_callstack_size(callstack_size);
   if (wosize == 0) return Atom(0);
   res = caml_alloc_shr_no_track_noexc(wosize, 0);
-  if (res != 0) caml_current_callstack_write(res);
+  if (res != 0) caml_current_callstack_write(res, alloc_idx);
   return res;
 }
 
 /* In this version, we are allowed to call the GC, so we use
    [caml_alloc], which is more efficient since it uses the minor
    heap.
    Should be called with [caml_memprof_suspended == 1] */
-static value capture_callstack(void)
+static value capture_callstack(unsigned alloc_idx)
 {
   value res;
   uintnat wosize = caml_current_callstack_size(callstack_size);
   CAMLassert(caml_memprof_suspended);
   res = caml_alloc(wosize, 0);
-  caml_current_callstack_write(res);
+  caml_current_callstack_write(res, alloc_idx);
   return res;
 }
 
@@ -547,7 +547,7 @@ void caml_memprof_track_alloc_shr(value block)
   n_samples = mt_generate_binom(Whsize_val(block));
   if (n_samples == 0) return;
 
-  callstack = capture_callstack_postponed();
+  callstack = capture_callstack_postponed(0);
   if (callstack == 0) return;
 
   new_tracked(n_samples, Wosize_val(block), 0, 0, block, callstack);
@@ -621,7 +621,7 @@ void caml_memprof_track_young(uintnat wosize, int from_caml,
     CAMLassert(encoded_alloc_lens == NULL);    /* No Comballoc in C! */
     caml_memprof_renew_minor_sample();
 
-    callstack = capture_callstack_postponed();
+    callstack = capture_callstack_postponed(0);
     if (callstack == 0) return;
 
     new_tracked(n_samples, wosize,
@@ -663,7 +663,7 @@ void caml_memprof_track_young(uintnat wosize, int from_caml,
     if (n_samples > 0) {
       uintnat *idx_ptr, t_idx;
 
-      callstack = capture_callstack();
+      callstack = capture_callstack(alloc_idx);
       t_idx = new_tracked(n_samples, alloc_wosz,
                           0, 1, Placeholder_offs(alloc_ofs), callstack);
       if (t_idx == Invalid_index) continue;
@@ -809,7 +809,7 @@ void caml_memprof_track_interned(header_t* block, header_t* blockend) {
       p = next_p;
     }
 
-    if (callstack == 0) callstack = capture_callstack_postponed();
+    if (callstack == 0) callstack = capture_callstack_postponed(0);
     if (callstack == 0) break;  /* OOM */
     new_tracked(mt_generate_binom(next_p - next_sample_p) + 1,
                 Wosize_hp(p), 1, is_young, Val_hp(p), callstack);

testsuite/tests/statmemprof/comballoc.byte.reference

@@ -0,0 +1,40 @@
+2: 0.42 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.42 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.42 true
+Raised by primitive operation at file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+2: 0.01 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.01 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.01 true
+Raised by primitive operation at file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+2: 0.83 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.83 false
+Raised by primitive operation at file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.83 true
+Raised by primitive operation at file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+OK

testsuite/tests/statmemprof/comballoc.ml

@@ -1,6 +1,12 @@
 (* TEST
    flags = "-g"
-   compare_programs = "false" *)
+   compare_programs = "false"
+   * bytecode
+     reference = "${test_source_directory}/comballoc.byte.reference"
+   * native
+     reference = "${test_source_directory}/comballoc.opt.reference"
+     compare_programs = "false"
+*)
 
 open Gc.Memprof
 
@@ -13,9 +19,17 @@ let test sampling_rate =
   let allocs = Array.make 257 0 in
   let deallocs = Array.make 257 0 in
   let promotes = Array.make 257 0 in
+  let callstacks = Array.make 257 None in
   start ~callstack_size:10
     ~minor_alloc_callback:(fun info ->
       allocs.(info.size) <- allocs.(info.size) + info.n_samples;
+(*      Printf.printf "%d\n%!" info.size;
+      Printexc.print_raw_backtrace stdout info.callstack;
+        flush stdout;*)
+      begin match callstacks.(info.size) with
+      | None -> callstacks.(info.size) <- Some info.callstack
+      | Some s -> assert (s = info.callstack)
+      end;
       Some (info.size, info.n_samples))
     ~minor_dealloc_callback:(fun (sz,n) ->
       deallocs.(sz) <- deallocs.(sz) + n)
@@ -24,9 +38,11 @@ let test sampling_rate =
       None)
     ~sampling_rate ();
   let iter = 100_000 in
-  let arr = Array.init iter (fun i ->
+  let arr = Array.make iter (0,0,0,0) in
+  for i = 0 to Array.length arr - 1 do
     let (_, (_, _, x)) = Sys.opaque_identity f i in
-    x) in
+    arr.(i) <- x;
+  done;
   Gc.minor ();
   stop ();
   ignore (Sys.opaque_identity arr);
@@ -46,7 +62,10 @@ let test sampling_rate =
          is a 5-sigma event, with probability less than 3*10^-7 *)
       Printf.printf "%d: %.2f %b\n" i
         (float_of_int allocs.(i) /. float_of_int total)
-        (promotes.(i) > 1000)
+        (promotes.(i) > 1000);
+      (match callstacks.(i) with
+       | Some s -> Printexc.print_raw_backtrace stdout s
+       | None -> assert false)
     end
   done
 

testsuite/tests/statmemprof/comballoc.opt.reference

@@ -0,0 +1,49 @@
+2: 0.42 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 2-19
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.42 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 6-18
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.42 true
+Raised by primitive operation at file "comballoc.ml" (inlined), line 13, characters 11-20
+Called from file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+2: 0.01 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 2-19
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.01 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 6-18
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.01 true
+Raised by primitive operation at file "comballoc.ml" (inlined), line 13, characters 11-20
+Called from file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+2: 0.83 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 2-19
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+3: 0.83 false
+Raised by primitive operation at file "comballoc.ml", line 16, characters 6-18
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+4: 0.83 true
+Raised by primitive operation at file "comballoc.ml" (inlined), line 13, characters 11-20
+Called from file "comballoc.ml", line 16, characters 13-17
+Called from file "comballoc.ml", line 43, characters 25-48
+Called from file "list.ml", line 110, characters 12-15
+Called from file "comballoc.ml", line 73, characters 2-35
+OK