Statmemprof support for runtime5

external/memtrace/src/memprof_tracer.ml

@@ -104,10 +104,10 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace =
         | exception e -> mark_failed s e) } in
   curr_active_tracer := Some s;
   bytes_before_ext_sample := draw_sampler_bytes s;
-  Gc.Memprof.start
+  let _ = Gc.Memprof.start
     ~sampling_rate
     ~callstack_size:max_int
-    tracker;
+    tracker in
   s
 
 let stop s =

ocaml/otherlibs/runtime_events/runtime_events.ml

@@ -41,9 +41,12 @@ type runtime_phase =
 | EV_MAJOR
 | EV_MAJOR_SWEEP
 | EV_MAJOR_MARK_ROOTS
+| EV_MAJOR_MEMPROF_ROOTS
 | EV_MAJOR_MARK
 | EV_MINOR
 | EV_MINOR_LOCAL_ROOTS
+| EV_MINOR_MEMPROF_ROOTS
+| EV_MINOR_MEMPROF_CLEAN
 | EV_MINOR_FINALIZED
 | EV_EXPLICIT_GC_MAJOR_SLICE
 | EV_FINALISE_UPDATE_FIRST
@@ -66,6 +69,7 @@ type runtime_phase =
 | EV_STW_HANDLER
 | EV_STW_LEADER
 | EV_MAJOR_FINISH_SWEEPING
+| EV_MAJOR_MEMPROF_CLEAN
 | EV_MINOR_FINALIZERS_ADMIN
 | EV_MINOR_REMEMBERED_SET
 | EV_MINOR_REMEMBERED_SET_PROMOTE
@@ -126,9 +130,12 @@ let runtime_phase_name phase =
   | EV_MAJOR -> "major"
     | EV_MAJOR_SWEEP -> "major_sweep"
   | EV_MAJOR_MARK_ROOTS -> "major_mark_roots"
+  | EV_MAJOR_MEMPROF_ROOTS -> "major_memprof_roots"
   | EV_MAJOR_MARK -> "major_mark"
   | EV_MINOR -> "minor"
   | EV_MINOR_LOCAL_ROOTS -> "minor_local_roots"
+  | EV_MINOR_MEMPROF_ROOTS -> "minor_memprof_roots"
+  | EV_MINOR_MEMPROF_CLEAN -> "minor_memprof_clean"
   | EV_MINOR_FINALIZED -> "minor_finalized"
   | EV_EXPLICIT_GC_MAJOR_SLICE -> "explicit_gc_major_slice"
   | EV_FINALISE_UPDATE_FIRST -> "finalise_update_first"
@@ -150,6 +157,7 @@ let runtime_phase_name phase =
   | EV_STW_HANDLER -> "stw_handler"
   | EV_STW_LEADER -> "stw_leader"
   | EV_MAJOR_FINISH_SWEEPING -> "major_finish_sweeping"
+  | EV_MAJOR_MEMPROF_CLEAN -> "major_memprof_clean"
   | EV_MINOR_FINALIZERS_ADMIN -> "minor_finalizers_admin"
   | EV_MINOR_REMEMBERED_SET -> "minor_remembered_set"
   | EV_MINOR_REMEMBERED_SET_PROMOTE -> "minor_remembered_set_promote"

ocaml/otherlibs/runtime_events/runtime_events.mli

@@ -99,9 +99,12 @@ type runtime_phase =
 | EV_MAJOR
 | EV_MAJOR_SWEEP
 | EV_MAJOR_MARK_ROOTS
+| EV_MAJOR_MEMPROF_ROOTS
 | EV_MAJOR_MARK
 | EV_MINOR
 | EV_MINOR_LOCAL_ROOTS
+| EV_MINOR_MEMPROF_ROOTS
+| EV_MINOR_MEMPROF_CLEAN
 | EV_MINOR_FINALIZED
 | EV_EXPLICIT_GC_MAJOR_SLICE
 | EV_FINALISE_UPDATE_FIRST
@@ -124,6 +127,7 @@ type runtime_phase =
 | EV_STW_HANDLER
 | EV_STW_LEADER
 | EV_MAJOR_FINISH_SWEEPING
+| EV_MAJOR_MEMPROF_CLEAN
 | EV_MINOR_FINALIZERS_ADMIN
 | EV_MINOR_REMEMBERED_SET
 | EV_MINOR_REMEMBERED_SET_PROMOTE

ocaml/otherlibs/systhreads/st_stubs.c

@@ -106,6 +106,8 @@ struct caml_thread_struct {
   value * gc_regs_buckets;   /* saved value of Caml_state->gc_regs_buckets */
   void * exn_handler;        /* saved value of Caml_state->exn_handler */
   char * async_exn_handler;  /* saved value of Caml_state->async_exn_handler */
+  memprof_thread_t memprof;  /* memprof's internal thread data structure */
+
 #ifndef NATIVE_CODE
   intnat trap_sp_off;      /* saved value of Caml_state->trap_sp_off */
   intnat trap_barrier_off; /* saved value of Caml_state->trap_barrier_off */
@@ -294,6 +296,7 @@ static void restore_runtime_state(caml_thread_t th)
   Caml_state->external_raise = th->external_raise;
   Caml_state->external_raise_async = th->external_raise_async;
 #endif
+  caml_memprof_enter_thread(th->memprof);
 }
 
 CAMLexport void caml_thread_restore_runtime_state(void)
@@ -392,6 +395,7 @@ static caml_thread_t caml_thread_new_info(void)
   th->external_raise_async = NULL;
 #endif
 
+  th->memprof = caml_memprof_new_thread(domain_state);
   return th;
 }
 
@@ -470,6 +474,7 @@ static void caml_thread_reinitialize(void)
   th = Active_thread->next;
   while (th != Active_thread) {
     next = th->next;
+    caml_memprof_delete_thread(th->memprof);
     caml_thread_free_info(th);
     th = next;
   }
@@ -557,11 +562,12 @@ static void caml_thread_domain_initialize_hook(void)
   new_thread->next = new_thread;
   new_thread->prev = new_thread;
   new_thread->backtrace_last_exn = Val_unit;
+  new_thread->memprof = caml_memprof_main_thread(Caml_state);
 
   st_tls_set(caml_thread_key, new_thread);
 
   Active_thread = new_thread;
-
+  caml_memprof_enter_thread(new_thread->memprof);
 }
 
 CAMLprim value caml_thread_yield(value unit);
@@ -608,7 +614,6 @@ CAMLprim value caml_thread_initialize(value unit)
   caml_domain_external_interrupt_hook = caml_thread_interrupt_hook;
   caml_domain_initialize_hook = caml_thread_domain_initialize_hook;
   caml_domain_stop_hook = caml_thread_domain_stop_hook;
-
   caml_atfork_hook = caml_thread_reinitialize;
 
   return Val_unit;
@@ -641,6 +646,10 @@ static void caml_thread_stop(void)
      always one more thread in the chain at this point in time. */
   CAMLassert(Active_thread->next != Active_thread);
 
+  /* Tell memprof that this thread is terminating */
+  caml_memprof_delete_thread(Active_thread->memprof);
+
+  /* Signal that the thread has terminated */
   caml_threadstatus_terminate(Terminated(Active_thread->descr));
 
   /* The following also sets Active_thread to a sane value in case the

ocaml/runtime/backtrace_byt.c

@@ -312,107 +312,124 @@ code_t caml_next_frame_pointer(value* stack_high, value ** sp,
   return NULL;
 }
 
-/* Stores upto [max_frames_value] frames of the current call stack to
-   return to the user. This is used not in an exception-raising context, but
-   only when the user requests to save the trace (hopefully less often).
-   Instead of using a bounded buffer as [Caml_state->stash_backtrace], we first
-   traverse the stack to compute the right size, then allocate space for the
-   trace. */
-
-static void get_callstack(value* sp, intnat trap_spoff,
-                          struct stack_info* stack,
-                          intnat max_frames,
-                          code_t** trace, intnat* trace_size)
+/* minimum size to allocate a backtrace (in slots) */
+#define MIN_BACKTRACE_SIZE 16
+
+/* Stores up to [max_slots] backtrace slots of the current call stack
+   to return to the user in [*backtrace_p] (with the allocated size in
+   [*alloc_size_p]). Returns the number of frames stored.  Instead of
+   using a bounded buffer as [Caml_state->stash_backtrace], we
+   dynamically grow the allocated space as required. */
+
+static size_t get_callstack(value* sp, intnat trap_spoff,
+                            struct stack_info* stack,
+                            intnat max_slots,
+                            backtrace_slot **backtrace_p,
+                            size_t *alloc_size_p)
 {
+  backtrace_slot *backtrace = *backtrace_p;
+  size_t alloc_size = *alloc_size_p;
   struct stack_info* parent = Stack_parent(stack);
   value *stack_high = Stack_high(stack);
-  value* saved_sp = sp;
-  intnat saved_trap_spoff = trap_spoff;
-
   CAMLnoalloc;
 
-  /* first compute the size of the trace */
-  {
-    *trace_size = 0;
-    while (*trace_size < max_frames) {
-      code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
-      if (p == NULL) {
-        if (parent == NULL) break;
-        sp = parent->sp;
-        trap_spoff = Long_val(sp[0]);
-        stack_high = Stack_high(parent);
-        parent = Stack_parent(parent);
-      } else {
-        ++*trace_size;
+  size_t slots = 0;
+  while (slots < max_slots) {
+    code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
+    if (!p) {
+      if (!parent) break;
+      sp = parent->sp;
+      trap_spoff = Long_val(sp[0]);
+      stack_high = Stack_high(parent);
+      parent = Stack_parent(parent);
+    } else {
+      if (slots == alloc_size) {
+        size_t new_size = alloc_size ? alloc_size * 2 : MIN_BACKTRACE_SIZE;
+        backtrace = caml_stat_resize_noexc(backtrace,
+                                           sizeof(backtrace_slot) * new_size);
+
+        if (!backtrace) { /* allocation failed */
+          *backtrace_p = NULL;
+          *alloc_size_p = 0;
+          return 0;
+        }
+        alloc_size = new_size;
       }
-    }
-  }
-
-  *trace = caml_stat_alloc(sizeof(code_t*) * *trace_size);
-
-  sp = saved_sp;
-  parent = Stack_parent(stack);
-  stack_high = Stack_high(stack);
-  trap_spoff = saved_trap_spoff;
 
-  /* then collect the trace */
-  {
-    uintnat trace_pos = 0;
-
-    while (trace_pos < *trace_size) {
-      code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
-      if (p == NULL) {
-        sp = parent->sp;
-        trap_spoff = Long_val(sp[0]);
-        stack_high = Stack_high(parent);
-        parent = Stack_parent(parent);
-      } else {
-        (*trace)[trace_pos] = p;
-        ++trace_pos;
-      }
+      backtrace[slots++] = p;
     }
   }
+  *backtrace_p = backtrace;
+  *alloc_size_p = alloc_size;
+  return slots;
 }
 
-static value alloc_callstack(code_t* trace, intnat trace_len)
+static value alloc_callstack(backtrace_slot *trace, size_t slots)
 {
   CAMLparam0();
   CAMLlocal1(callstack);
   int i;
-  callstack = caml_alloc(trace_len, 0);
-  for (i = 0; i < trace_len; i++)
+  callstack = caml_alloc(slots, 0);
+  for (i = 0; i < slots; i++)
     Store_field(callstack, i, Val_backtrace_slot(trace[i]));
   caml_stat_free(trace);
   CAMLreturn(callstack);
 }
 
+/* Obtain up to [max_slots] of the callstack of the current domain,
+ * including parent fibers. The callstack is written into [*buffer_p],
+ * current size [*alloc_size_p], which should be reallocated (on the C
+ * heap) if required. Returns the number of slots obtained.
+ *
+ * [alloc_idx] is ignored, and must be negative (this interface is
+ * also used by the native-code runtime, in which [alloc_idx] is
+ * meaningful.
+ */
+
+size_t caml_get_callstack(size_t max_slots,
+                          backtrace_slot **buffer_p,
+                          size_t *alloc_size_p,
+                          ssize_t alloc_idx)
+{
+  CAMLassert(alloc_idx < 1); /* allocation indexes not used in bytecode */
+  return get_callstack(Caml_state->current_stack->sp,
+                       Caml_state->trap_sp_off,
+                       Caml_state->current_stack,
+                       max_slots,
+                       buffer_p, alloc_size_p);
+}
+
 CAMLprim value caml_get_current_callstack (value max_frames_value)
 {
-  code_t* trace;
-  intnat trace_len;
-  get_callstack(Caml_state->current_stack->sp, Caml_state->trap_sp_off,
-                Caml_state->current_stack, Long_val(max_frames_value),
-                &trace, &trace_len);
-  return alloc_callstack(trace, trace_len);
+  backtrace_slot *backtrace = NULL;
+  size_t trace_size = 0;
+  size_t slots = get_callstack(Caml_state->current_stack->sp,
+                               Caml_state->trap_sp_off,
+                               Caml_state->current_stack,
+                               Long_val(max_frames_value),
+                               &backtrace, &trace_size);
+  return alloc_callstack(backtrace, slots);
 }
 
 CAMLprim value caml_get_continuation_callstack (value cont, value max_frames)
 {
-  code_t* trace;
-  intnat trace_len;
+  backtrace_slot *backtrace = NULL;
+  size_t trace_size = 0;
+  size_t slots;
   struct stack_info *stack;
   value *sp;
 
   stack = Ptr_val(caml_continuation_use(cont));
   {
     CAMLnoalloc; /* GC must not see the stack outside the cont */
     sp = stack->sp;
-    get_callstack(sp, Long_val(sp[0]), stack, Long_val(max_frames),
-                  &trace, &trace_len);
+    slots = get_callstack(sp, Long_val(sp[0]),
+                          stack, Long_val(max_frames),
+                          &backtrace, &trace_size);
     caml_continuation_replace(cont, stack);
   }
 
-  return alloc_callstack(trace, trace_len);
+  return alloc_callstack(backtrace, slots);
 }