2019-04-23 00:27:31 -07:00
|
|
|
/**************************************************************************/
|
|
|
|
/* */
|
|
|
|
/* OCaml */
|
|
|
|
/* */
|
2019-09-26 13:34:12 -07:00
|
|
|
/* Jacques-Henri Jourdan, projet Gallium, INRIA Paris */
|
2019-04-23 00:27:31 -07:00
|
|
|
/* */
|
|
|
|
/* Copyright 2016 Institut National de Recherche en Informatique et */
|
|
|
|
/* en Automatique. */
|
|
|
|
/* */
|
|
|
|
/* All rights reserved. This file is distributed under the terms of */
|
|
|
|
/* the GNU Lesser General Public License version 2.1, with the */
|
|
|
|
/* special exception on linking described in the file LICENSE. */
|
|
|
|
/* */
|
|
|
|
/**************************************************************************/
|
|
|
|
|
|
|
|
#define CAML_INTERNALS
|
|
|
|
|
|
|
|
#include <math.h>
|
|
|
|
#include <string.h>
|
|
|
|
#include "caml/memprof.h"
|
|
|
|
#include "caml/fail.h"
|
|
|
|
#include "caml/alloc.h"
|
|
|
|
#include "caml/callback.h"
|
|
|
|
#include "caml/signals.h"
|
|
|
|
#include "caml/memory.h"
|
|
|
|
#include "caml/minor_gc.h"
|
|
|
|
#include "caml/backtrace_prim.h"
|
|
|
|
#include "caml/weak.h"
|
|
|
|
#include "caml/stack.h"
|
2019-05-17 06:51:16 -07:00
|
|
|
#include "caml/misc.h"
|
2019-09-04 05:36:23 -07:00
|
|
|
#include "caml/compact.h"
|
|
|
|
#include "caml/printexc.h"
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
#define MT_STATE_SIZE 624
|
|
|
|
|
|
|
|
static uint32_t mt_state[MT_STATE_SIZE];
|
2019-04-23 00:27:31 -07:00
|
|
|
static uint32_t mt_index;
|
|
|
|
|
|
|
|
/* [lambda] is the mean number of samples for each allocated word (including
|
|
|
|
block headers). */
|
|
|
|
static double lambda = 0;
|
2019-05-17 06:51:16 -07:00
|
|
|
/* Precomputed value of [1/log(1-lambda)], for fast sampling of
|
|
|
|
geometric distribution.
|
|
|
|
Dummy if [lambda = 0]. */
|
|
|
|
static double one_log1m_lambda;
|
2019-05-09 08:39:35 -07:00
|
|
|
|
2019-04-23 00:27:31 -07:00
|
|
|
int caml_memprof_suspended = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
static intnat callstack_size;
|
|
|
|
|
|
|
|
static value callback_alloc_minor, callback_alloc_major,
|
|
|
|
callback_promote, callback_dealloc_minor, callback_dealloc_major;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-05-17 06:51:16 -07:00
|
|
|
/* Pointer to the word following the next sample in the minor
|
2019-06-05 23:39:26 -07:00
|
|
|
heap. Equals [Caml_state->young_alloc_start] if no sampling is planned in
|
2019-05-17 06:51:16 -07:00
|
|
|
the current minor heap.
|
2019-06-03 07:13:15 -07:00
|
|
|
Invariant: [caml_memprof_young_trigger <= Caml_state->young_ptr].
|
2019-05-09 08:39:35 -07:00
|
|
|
*/
|
|
|
|
value* caml_memprof_young_trigger;
|
|
|
|
|
2019-04-23 00:27:31 -07:00
|
|
|
/* Whether memprof has been initialized. */
|
|
|
|
static int init = 0;
|
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
/* Whether memprof is started. */
|
|
|
|
static int started = 0;
|
|
|
|
|
2020-01-29 09:14:05 -08:00
|
|
|
/* Buffer used to compute backtraces */
|
|
|
|
static value* callstack_buffer = NULL;
|
|
|
|
static intnat callstack_buffer_len = 0;
|
|
|
|
|
2019-04-23 00:27:31 -07:00
|
|
|
/**** Statistical sampling ****/
|
|
|
|
|
2019-05-09 08:39:35 -07:00
|
|
|
static double mt_generate_uniform(void)
|
|
|
|
{
|
2019-04-23 00:27:31 -07:00
|
|
|
int i;
|
|
|
|
uint32_t y;
|
|
|
|
|
|
|
|
/* Mersenne twister PRNG */
|
2019-09-04 05:36:23 -07:00
|
|
|
if (mt_index == MT_STATE_SIZE) {
|
|
|
|
for (i = 0; i < 227; i++) {
|
2019-04-23 00:27:31 -07:00
|
|
|
y = (mt_state[i] & 0x80000000) + (mt_state[i+1] & 0x7fffffff);
|
|
|
|
mt_state[i] = mt_state[i+397] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
for (i = 227; i < MT_STATE_SIZE - 1; i++) {
|
2019-04-23 00:27:31 -07:00
|
|
|
y = (mt_state[i] & 0x80000000) + (mt_state[i+1] & 0x7fffffff);
|
|
|
|
mt_state[i] = mt_state[i-227] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
y = (mt_state[MT_STATE_SIZE - 1] & 0x80000000) + (mt_state[0] & 0x7fffffff);
|
|
|
|
mt_state[MT_STATE_SIZE - 1] =
|
|
|
|
mt_state[396] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
|
2019-04-23 00:27:31 -07:00
|
|
|
mt_index = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
y = mt_state[mt_index];
|
|
|
|
y = y ^ (y >> 11);
|
|
|
|
y = y ^ ((y << 7) & 0x9d2c5680);
|
|
|
|
y = y ^ ((y << 15) & 0xefc60000);
|
|
|
|
y = y ^ (y >> 18);
|
|
|
|
|
|
|
|
mt_index++;
|
|
|
|
return y*2.3283064365386962890625e-10 + /* 2^-32 */
|
|
|
|
1.16415321826934814453125e-10; /* 2^-33 */
|
|
|
|
}
|
|
|
|
|
2019-05-17 06:51:16 -07:00
|
|
|
/* Simulate a geometric variable of parameter [lambda].
|
2020-01-07 04:30:26 -08:00
|
|
|
The result is clipped in [1..Max_long] */
|
2019-09-04 05:36:23 -07:00
|
|
|
static uintnat mt_generate_geom(void)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2020-01-07 04:30:26 -08:00
|
|
|
double res;
|
|
|
|
CAMLassert(lambda > 0.);
|
2019-05-17 06:51:16 -07:00
|
|
|
/* We use the float versions of exp/log, since these functions are
|
|
|
|
significantly faster, and we really don't need much precision
|
|
|
|
here. The entropy contained in [next_mt_generate_geom] is anyway
|
|
|
|
bounded by the entropy provided by [mt_generate_uniform], which
|
|
|
|
is 32bits. */
|
2020-01-07 04:30:26 -08:00
|
|
|
res = 1 + logf(mt_generate_uniform()) * one_log1m_lambda;
|
2019-05-23 07:00:08 -07:00
|
|
|
if (res > Max_long) return Max_long;
|
2019-05-17 06:51:16 -07:00
|
|
|
return (uintnat)res;
|
2019-04-23 00:27:31 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
static uintnat next_mt_generate_geom;
|
2019-05-17 06:51:16 -07:00
|
|
|
/* Simulate a binomial variable of parameters [len] and [lambda].
|
|
|
|
This sampling algorithm has running time linear with [len *
|
|
|
|
lambda]. We could use more a involved algorithm, but this should
|
|
|
|
be good enough since, in the average use case, [lambda] <= 0.01 and
|
|
|
|
therefore the generation of the binomial variable is amortized by
|
|
|
|
the initialialization of the corresponding block.
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-05-17 06:51:16 -07:00
|
|
|
If needed, we could use algorithm BTRS from the paper:
|
|
|
|
Hormann, Wolfgang. "The generation of binomial random variates."
|
|
|
|
Journal of statistical computation and simulation 46.1-2 (1993), pp101-110.
|
|
|
|
*/
|
|
|
|
static uintnat mt_generate_binom(uintnat len)
|
|
|
|
{
|
|
|
|
uintnat res;
|
2020-01-07 04:30:26 -08:00
|
|
|
CAMLassert(lambda > 0. && len < Max_long);
|
2019-09-04 05:36:23 -07:00
|
|
|
for (res = 0; next_mt_generate_geom < len; res++)
|
|
|
|
next_mt_generate_geom += mt_generate_geom();
|
|
|
|
next_mt_generate_geom -= len;
|
2019-05-17 06:51:16 -07:00
|
|
|
return res;
|
2019-04-23 00:27:31 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/**** Capturing the call stack *****/
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* This function is called in, e.g., [caml_alloc_shr], which
|
|
|
|
guarantees that the GC is not called. Clients may use it in a
|
|
|
|
context where the heap is in an invalid state, or when the roots
|
|
|
|
are not properly registered. Therefore, we do not use [caml_alloc],
|
|
|
|
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. */
|
2020-01-21 06:34:28 -08:00
|
|
|
static value capture_callstack_postponed()
|
2019-09-04 05:36:23 -07:00
|
|
|
{
|
|
|
|
value res;
|
2020-01-29 09:14:05 -08:00
|
|
|
intnat callstack_len =
|
|
|
|
caml_collect_current_callstack(&callstack_buffer, &callstack_buffer_len,
|
|
|
|
callstack_size, -1);
|
|
|
|
if (callstack_len == 0)
|
|
|
|
return Atom(0);
|
|
|
|
res = caml_alloc_shr_no_track_noexc(callstack_len, 0);
|
|
|
|
if (res == 0)
|
|
|
|
return Atom(0);
|
|
|
|
memcpy(Op_val(res), callstack_buffer, sizeof(value) * callstack_len);
|
|
|
|
if (callstack_buffer_len > 256 && callstack_buffer_len > callstack_len * 8) {
|
|
|
|
caml_stat_free(callstack_buffer);
|
|
|
|
callstack_buffer = NULL;
|
|
|
|
callstack_buffer_len = 0;
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
return res;
|
|
|
|
}
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* 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] */
|
2020-01-21 06:34:44 -08:00
|
|
|
static value capture_callstack(int alloc_idx)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
value res;
|
2020-01-29 09:14:05 -08:00
|
|
|
intnat callstack_len =
|
|
|
|
caml_collect_current_callstack(&callstack_buffer, &callstack_buffer_len,
|
|
|
|
callstack_size, alloc_idx);
|
2019-09-04 05:36:23 -07:00
|
|
|
CAMLassert(caml_memprof_suspended);
|
2020-01-29 09:14:05 -08:00
|
|
|
res = caml_alloc(callstack_len, 0);
|
|
|
|
memcpy(Op_val(res), callstack_buffer, sizeof(value) * callstack_len);
|
|
|
|
if (callstack_buffer_len > 256 && callstack_buffer_len > callstack_len * 8) {
|
|
|
|
caml_stat_free(callstack_buffer);
|
|
|
|
callstack_buffer = NULL;
|
|
|
|
callstack_buffer_len = 0;
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
return res;
|
|
|
|
}
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/**** Data structures for tracked blocks. ****/
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
struct tracked {
|
|
|
|
/* Memory block being sampled. This is a weak GC root. */
|
|
|
|
value block;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Number of samples in this block. */
|
|
|
|
uintnat n_samples;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2020-01-10 06:51:03 -08:00
|
|
|
/* The size of this block. */
|
|
|
|
uintnat wosize;
|
2019-05-17 06:51:16 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* The value returned by the previous callback for this block, or
|
|
|
|
the callstack if the alloc callback has not been called yet.
|
|
|
|
This is a strong GC root. */
|
|
|
|
value user_data;
|
2019-05-17 06:51:16 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether this block has been initially allocated in the minor heap. */
|
|
|
|
unsigned int alloc_young : 1;
|
2019-05-17 06:51:16 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether this block comes from unmarshalling. */
|
|
|
|
unsigned int unmarshalled : 1;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether this block has been promoted. Implies [alloc_young]. */
|
|
|
|
unsigned int promoted : 1;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether this block has been deallocated. */
|
|
|
|
unsigned int deallocated : 1;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether the allocation callback has been called. */
|
|
|
|
unsigned int cb_alloc_called : 1;
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether the promotion callback has been called. */
|
|
|
|
unsigned int cb_promote_called : 1;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether the deallocation callback has been called. */
|
|
|
|
unsigned int cb_dealloc_called : 1;
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether this entry is deleted. */
|
|
|
|
unsigned int deleted : 1;
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Whether a callback is currently running for this entry. */
|
|
|
|
unsigned int callback_running : 1;
|
2019-06-05 07:41:07 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Pointer to the [t_idx] variable in the [run_callback] frame which
|
|
|
|
is currently running the callback for this entry. This is needed
|
|
|
|
to make [run_callback] reetrant, in the case it is called
|
|
|
|
simultaneously by several threads. */
|
|
|
|
uintnat* idx_ptr;
|
|
|
|
};
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
/* During the alloc callback for a minor allocation, the block being
|
|
|
|
sampled is not yet allocated. Instead, we place in the block field
|
|
|
|
a value computed with the following macro: */
|
|
|
|
#define Placeholder_magic 0x04200000
|
|
|
|
#define Placeholder_offs(offset) (Val_long(offset + Placeholder_magic))
|
|
|
|
#define Offs_placeholder(block) (Long_val(block) & 0xFFFF)
|
|
|
|
#define Is_placeholder(block) \
|
|
|
|
(Is_long(block) && (Long_val(block) & ~(uintnat)0xFFFF) == Placeholder_magic)
|
|
|
|
|
|
|
|
/* When an entry is deleted, its index is replaced by that integer. */
|
|
|
|
#define Invalid_index (~(uintnat)0)
|
|
|
|
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
static struct tracking_state {
|
|
|
|
struct tracked* entries;
|
|
|
|
/* The allocated capacity of the entries array */
|
|
|
|
uintnat alloc_len;
|
|
|
|
/* The number of active entries. (len <= alloc_len) */
|
|
|
|
uintnat len;
|
|
|
|
/* Before this position, the [block] and [user_data] fields point to
|
|
|
|
the major heap (young <= len). */
|
|
|
|
uintnat young;
|
|
|
|
/* There are no pending callbacks before this position (callback <= len). */
|
|
|
|
uintnat callback;
|
|
|
|
/* There are no blocks to be deleted before this position */
|
|
|
|
uintnat delete;
|
|
|
|
} trackst;
|
|
|
|
|
|
|
|
#define MIN_TRACKST_ALLOC_LEN 128
|
|
|
|
|
|
|
|
|
|
|
|
/* Reallocate the [trackst] array if it is either too small or too
|
|
|
|
large.
|
|
|
|
Returns 1 if reallocation succeeded --[trackst.alloc_len] is at
|
|
|
|
least [trackst.len]--, and 0 otherwise. */
|
|
|
|
static int realloc_trackst(void) {
|
|
|
|
uintnat new_alloc_len;
|
|
|
|
struct tracked* new_entries;
|
|
|
|
if (trackst.len <= trackst.alloc_len &&
|
|
|
|
(4*trackst.len >= trackst.alloc_len ||
|
|
|
|
trackst.alloc_len == MIN_TRACKST_ALLOC_LEN))
|
|
|
|
return 1;
|
|
|
|
new_alloc_len = trackst.len * 2;
|
|
|
|
if (new_alloc_len < MIN_TRACKST_ALLOC_LEN)
|
|
|
|
new_alloc_len = MIN_TRACKST_ALLOC_LEN;
|
|
|
|
new_entries = caml_stat_resize_noexc(trackst.entries,
|
|
|
|
new_alloc_len * sizeof(struct tracked));
|
|
|
|
if (new_entries == NULL) return 0;
|
|
|
|
trackst.entries = new_entries;
|
|
|
|
trackst.alloc_len = new_alloc_len;
|
|
|
|
return 1;
|
|
|
|
}
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2020-02-11 01:33:55 -08:00
|
|
|
Caml_inline uintnat new_tracked(uintnat n_samples, uintnat wosize,
|
|
|
|
int is_unmarshalled, int is_young,
|
|
|
|
value block, value user_data)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
struct tracked *t;
|
|
|
|
trackst.len++;
|
|
|
|
if (!realloc_trackst()) {
|
|
|
|
trackst.len--;
|
|
|
|
return Invalid_index;
|
|
|
|
}
|
|
|
|
t = &trackst.entries[trackst.len - 1];
|
|
|
|
t->block = block;
|
|
|
|
t->n_samples = n_samples;
|
2020-01-10 06:51:03 -08:00
|
|
|
t->wosize = wosize;
|
2019-09-04 05:36:23 -07:00
|
|
|
t->user_data = user_data;
|
|
|
|
t->idx_ptr = NULL;
|
|
|
|
t->alloc_young = is_young;
|
|
|
|
t->unmarshalled = is_unmarshalled;
|
|
|
|
t->promoted = 0;
|
|
|
|
t->deallocated = 0;
|
|
|
|
t->cb_alloc_called = t->cb_promote_called = t->cb_dealloc_called = 0;
|
|
|
|
t->deleted = 0;
|
|
|
|
t->callback_running = 0;
|
|
|
|
return trackst.len - 1;
|
2019-05-09 08:39:35 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
static void mark_deleted(uintnat t_idx)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
struct tracked* t = &trackst.entries[t_idx];
|
|
|
|
t->deleted = 1;
|
|
|
|
t->user_data = Val_unit;
|
|
|
|
t->block = Val_unit;
|
|
|
|
if (t_idx < trackst.delete) trackst.delete = t_idx;
|
|
|
|
CAMLassert(t->idx_ptr == NULL);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* The return value is an exception or [Val_unit] iff [*t_idx] is set to
|
|
|
|
[Invalid_index]. In this case, the entry is deleted.
|
|
|
|
Otherwise, the return value is a [Some(...)] block. */
|
2020-02-11 01:33:55 -08:00
|
|
|
Caml_inline value run_callback_exn(uintnat *t_idx, value cb, value param) {
|
2019-09-04 05:36:23 -07:00
|
|
|
struct tracked* t = &trackst.entries[*t_idx];
|
2019-05-09 08:39:35 -07:00
|
|
|
value res;
|
2019-09-04 05:36:23 -07:00
|
|
|
CAMLassert(!t->callback_running && t->idx_ptr == NULL);
|
2020-01-07 04:30:26 -08:00
|
|
|
CAMLassert(lambda > 0.);
|
2019-09-04 05:36:23 -07:00
|
|
|
|
|
|
|
t->callback_running = 1;
|
|
|
|
t->idx_ptr = t_idx;
|
|
|
|
res = caml_callback_exn(cb, param);
|
|
|
|
/* The call above can modify [*t_idx] and thus invalidate [t]. */
|
|
|
|
if (*t_idx == Invalid_index) {
|
|
|
|
/* Make sure this entry has not been removed by [caml_memprof_set] */
|
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
t = &trackst.entries[*t_idx];
|
|
|
|
t->idx_ptr = NULL;
|
|
|
|
t->callback_running = 0;
|
|
|
|
if (Is_exception_result(res) || res == Val_unit) {
|
|
|
|
/* Callback raised an exception or returned None or (), discard
|
|
|
|
this entry. */
|
|
|
|
mark_deleted(*t_idx);
|
|
|
|
*t_idx = Invalid_index;
|
|
|
|
}
|
2019-04-23 00:27:31 -07:00
|
|
|
return res;
|
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Run all the needed callbacks for a given entry.
|
|
|
|
In case of a thread context switch during a callback, this can be
|
|
|
|
called in a reetrant way.
|
|
|
|
If [*t_idx] equals [trackst.callback], then this function
|
|
|
|
increments [trackst.callback].
|
|
|
|
The index of the entry may change. It is set to [Invalid_index] if
|
|
|
|
the entry is discarded.
|
|
|
|
Returns:
|
|
|
|
- An exception result if the callback raised an exception
|
|
|
|
- Val_long(0) == Val_unit == None otherwise
|
|
|
|
*/
|
|
|
|
static value handle_entry_callbacks_exn(uintnat* t_idx)
|
2019-05-23 07:00:08 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
value sample_info, res, user_data; /* No need to make these roots */
|
|
|
|
struct tracked* t = &trackst.entries[*t_idx];
|
|
|
|
if (*t_idx == trackst.callback) trackst.callback++;
|
|
|
|
|
|
|
|
if (t->deleted || t->callback_running) return Val_unit;
|
|
|
|
|
|
|
|
if (!t->cb_alloc_called) {
|
|
|
|
t->cb_alloc_called = 1;
|
|
|
|
CAMLassert(Is_block(t->block)
|
2020-01-07 04:30:26 -08:00
|
|
|
|| Is_placeholder(t->block)
|
2019-09-04 05:36:23 -07:00
|
|
|
|| t->deallocated);
|
2020-01-10 06:51:03 -08:00
|
|
|
sample_info = caml_alloc_small(4, 0);
|
2019-09-04 05:36:23 -07:00
|
|
|
Field(sample_info, 0) = Val_long(t->n_samples);
|
2020-01-10 06:51:03 -08:00
|
|
|
Field(sample_info, 1) = Val_long(t->wosize);
|
|
|
|
Field(sample_info, 2) = Val_long(t->unmarshalled);
|
|
|
|
Field(sample_info, 3) = t->user_data;
|
2019-09-04 05:36:23 -07:00
|
|
|
t->user_data = Val_unit;
|
|
|
|
res = run_callback_exn(t_idx,
|
|
|
|
t->alloc_young ? callback_alloc_minor : callback_alloc_major,
|
|
|
|
sample_info);
|
|
|
|
if (*t_idx == Invalid_index)
|
|
|
|
return res;
|
|
|
|
CAMLassert(!Is_exception_result(res) && Is_block(res) && Tag_val(res) == 0
|
|
|
|
&& Wosize_val(res) == 1);
|
|
|
|
t = &trackst.entries[*t_idx];
|
|
|
|
t->user_data = Field(res, 0);
|
|
|
|
if (Is_block(t->user_data) && Is_young(t->user_data) &&
|
|
|
|
*t_idx < trackst.young)
|
|
|
|
trackst.young = *t_idx;
|
|
|
|
}
|
2019-04-23 00:27:31 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
if (t->promoted && !t->cb_promote_called) {
|
|
|
|
t->cb_promote_called = 1;
|
|
|
|
user_data = t->user_data;
|
|
|
|
t->user_data = Val_unit;
|
|
|
|
res = run_callback_exn(t_idx, callback_promote, user_data);
|
|
|
|
if (*t_idx == Invalid_index)
|
|
|
|
return res;
|
|
|
|
CAMLassert(!Is_exception_result(res) && Is_block(res) && Tag_val(res) == 0
|
|
|
|
&& Wosize_val(res) == 1);
|
|
|
|
t = &trackst.entries[*t_idx];
|
|
|
|
t->user_data = Field(res, 0);
|
|
|
|
if (Is_block(t->user_data) && Is_young(t->user_data) &&
|
|
|
|
*t_idx < trackst.young)
|
|
|
|
trackst.young = *t_idx;
|
2019-05-23 07:00:08 -07:00
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
|
|
|
|
if (t->deallocated && !t->cb_dealloc_called) {
|
|
|
|
value cb = (t->promoted || !t->alloc_young) ?
|
|
|
|
callback_dealloc_major : callback_dealloc_minor;
|
|
|
|
t->cb_dealloc_called = 1;
|
|
|
|
user_data = t->user_data;
|
|
|
|
t->user_data = Val_unit;
|
|
|
|
res = run_callback_exn(t_idx, cb, user_data);
|
|
|
|
/* [t] is invalid, but we do no longer use it. */
|
|
|
|
CAMLassert(*t_idx == Invalid_index);
|
|
|
|
CAMLassert(Is_exception_result(res) || res == Val_unit);
|
|
|
|
return res;
|
|
|
|
}
|
|
|
|
|
|
|
|
return Val_unit;
|
2019-05-23 07:00:08 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Remove any deleted entries, updating callback and young */
|
|
|
|
static void flush_deleted(void)
|
2019-05-23 07:00:08 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
uintnat i = trackst.delete, j = i;
|
|
|
|
while (i < trackst.len) {
|
|
|
|
if (!trackst.entries[i].deleted) {
|
|
|
|
if (trackst.entries[i].idx_ptr != NULL)
|
|
|
|
*trackst.entries[i].idx_ptr = j;
|
|
|
|
trackst.entries[j] = trackst.entries[i];
|
|
|
|
j++;
|
2019-05-23 07:00:08 -07:00
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
i++;
|
|
|
|
if (trackst.young == i) trackst.young = j;
|
|
|
|
if (trackst.callback == i) trackst.callback = j;
|
2019-05-23 04:32:22 -07:00
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
trackst.delete = trackst.len = j;
|
|
|
|
CAMLassert(trackst.callback <= trackst.len);
|
|
|
|
CAMLassert(trackst.young <= trackst.len);
|
|
|
|
realloc_trackst();
|
|
|
|
}
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
void caml_memprof_check_action_pending(void) {
|
|
|
|
if (!caml_memprof_suspended && trackst.callback < trackst.len)
|
|
|
|
caml_set_action_pending();
|
2019-04-23 00:27:31 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* In case of a thread context switch during a callback, this can be
|
|
|
|
called in a reetrant way. */
|
2019-10-14 05:19:11 -07:00
|
|
|
value caml_memprof_handle_postponed_exn(void)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
value res = Val_unit;
|
|
|
|
if (caml_memprof_suspended) return res;
|
|
|
|
caml_memprof_suspended = 1;
|
|
|
|
while (trackst.callback < trackst.len) {
|
|
|
|
uintnat i = trackst.callback;
|
|
|
|
res = handle_entry_callbacks_exn(&i);
|
|
|
|
if (Is_exception_result(res)) break;
|
|
|
|
}
|
|
|
|
caml_memprof_suspended = 0;
|
|
|
|
caml_memprof_check_action_pending(); /* Needed in case of an exception */
|
|
|
|
flush_deleted();
|
|
|
|
return res;
|
|
|
|
}
|
2019-10-14 05:19:11 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
void caml_memprof_oldify_young_roots(void)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
/* This loop should always have a small number of iteration (when
|
|
|
|
compared to the size of the minor heap), because the young
|
|
|
|
pointer should always be close to the end of the array. Indeed,
|
|
|
|
it is only moved back when returning from a callback triggered by
|
|
|
|
allocation or promotion, which can only happen for blocks
|
|
|
|
allocated recently, which are close to the end of the trackst
|
|
|
|
array. */
|
|
|
|
for (i = trackst.young; i < trackst.len; i++)
|
|
|
|
caml_oldify_one(trackst.entries[i].user_data,
|
|
|
|
&trackst.entries[i].user_data);
|
|
|
|
}
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
void caml_memprof_minor_update(void)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
/* See comment in [caml_memprof_oldify_young_roots] for the number
|
|
|
|
of iterations of this loop. */
|
|
|
|
for (i = trackst.young; i < trackst.len; i++) {
|
|
|
|
struct tracked *t = &trackst.entries[i];
|
|
|
|
CAMLassert(Is_block(t->block) || t->deleted || t->deallocated ||
|
2020-01-07 04:30:26 -08:00
|
|
|
Is_placeholder(t->block));
|
2019-09-04 05:36:23 -07:00
|
|
|
if (Is_block(t->block) && Is_young(t->block)) {
|
|
|
|
if (Hd_val(t->block) == 0) {
|
|
|
|
/* Block has been promoted */
|
|
|
|
t->block = Field(t->block, 0);
|
|
|
|
t->promoted = 1;
|
|
|
|
} else {
|
|
|
|
/* Block is dead */
|
2020-01-07 04:30:26 -08:00
|
|
|
CAMLassert_young_header(Hd_val(t->block));
|
2019-09-04 05:36:23 -07:00
|
|
|
t->block = Val_unit;
|
|
|
|
t->deallocated = 1;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if (trackst.callback > trackst.young) {
|
|
|
|
trackst.callback = trackst.young;
|
|
|
|
caml_memprof_check_action_pending();
|
2019-05-23 07:00:08 -07:00
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
trackst.young = trackst.len;
|
|
|
|
}
|
2019-05-23 07:00:08 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
void caml_memprof_do_roots(scanning_action f)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
for (i = 0; i < trackst.len; i++)
|
|
|
|
f(trackst.entries[i].user_data, &trackst.entries[i].user_data);
|
2019-05-23 07:00:08 -07:00
|
|
|
}
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
void caml_memprof_update_clean_phase(void)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
for (i = 0; i < trackst.len; i++) {
|
|
|
|
struct tracked *t = &trackst.entries[i];
|
|
|
|
if (Is_block(t->block) && !Is_young(t->block)) {
|
|
|
|
CAMLassert(Is_in_heap(t->block));
|
|
|
|
CAMLassert(!t->alloc_young || t->promoted);
|
|
|
|
if (Is_white_val(t->block)) {
|
|
|
|
t->block = Val_unit;
|
|
|
|
t->deallocated = 1;
|
|
|
|
}
|
|
|
|
}
|
2019-05-29 06:32:05 -07:00
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
trackst.callback = 0;
|
|
|
|
caml_memprof_check_action_pending();
|
|
|
|
}
|
|
|
|
|
|
|
|
void caml_memprof_invert_tracked(void)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
for (i = 0; i < trackst.len; i++)
|
|
|
|
caml_invert_root(trackst.entries[i].block, &trackst.entries[i].block);
|
2019-05-29 06:32:05 -07:00
|
|
|
}
|
|
|
|
|
2019-05-23 07:00:08 -07:00
|
|
|
/**** Sampling procedures ****/
|
|
|
|
|
2019-05-23 04:32:22 -07:00
|
|
|
void caml_memprof_track_alloc_shr(value block)
|
|
|
|
{
|
2019-09-04 05:36:23 -07:00
|
|
|
uintnat n_samples;
|
2019-05-29 07:51:10 -07:00
|
|
|
value callstack = 0;
|
2019-05-23 04:32:22 -07:00
|
|
|
CAMLassert(Is_in_heap(block));
|
2019-09-04 05:36:23 -07:00
|
|
|
|
2019-05-23 04:32:22 -07:00
|
|
|
/* This test also makes sure memprof is initialized. */
|
2019-05-23 07:00:08 -07:00
|
|
|
if (lambda == 0 || caml_memprof_suspended) return;
|
2019-09-04 05:36:23 -07:00
|
|
|
|
|
|
|
n_samples = mt_generate_binom(Whsize_val(block));
|
|
|
|
if (n_samples == 0) return;
|
|
|
|
|
2020-01-21 06:34:28 -08:00
|
|
|
callstack = capture_callstack_postponed();
|
2019-09-04 05:36:23 -07:00
|
|
|
if (callstack == 0) return;
|
|
|
|
|
2020-01-10 06:51:03 -08:00
|
|
|
new_tracked(n_samples, Wosize_val(block), 0, 0, block, callstack);
|
2019-09-04 05:36:23 -07:00
|
|
|
caml_memprof_check_action_pending();
|
2019-05-23 04:32:22 -07:00
|
|
|
}
|
|
|
|
|
2019-05-09 08:39:35 -07:00
|
|
|
/* Shifts the next sample in the minor heap by [n] words. Essentially,
|
|
|
|
this tells the sampler to ignore the next [n] words of the minor
|
|
|
|
heap. */
|
|
|
|
static void shift_sample(uintnat n)
|
|
|
|
{
|
2019-06-05 23:39:26 -07:00
|
|
|
if (caml_memprof_young_trigger - Caml_state->young_alloc_start > n)
|
2019-05-09 08:39:35 -07:00
|
|
|
caml_memprof_young_trigger -= n;
|
|
|
|
else
|
2019-06-05 23:39:26 -07:00
|
|
|
caml_memprof_young_trigger = Caml_state->young_alloc_start;
|
2019-05-09 08:39:35 -07:00
|
|
|
caml_update_young_limit();
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Renew the next sample in the minor heap. This needs to be called
|
|
|
|
after each minor sampling and after each minor collection. In
|
2019-05-17 06:51:16 -07:00
|
|
|
practice, this is called at each sampling in the minor heap and at
|
|
|
|
each minor collection. Extra calls do not change the statistical
|
|
|
|
properties of the sampling because of the memorylessness of the
|
|
|
|
geometric distribution. */
|
2019-05-09 08:39:35 -07:00
|
|
|
void caml_memprof_renew_minor_sample(void)
|
|
|
|
{
|
|
|
|
|
2019-05-23 07:00:08 -07:00
|
|
|
if (lambda == 0) /* No trigger in the current minor heap. */
|
2019-06-05 23:39:26 -07:00
|
|
|
caml_memprof_young_trigger = Caml_state->young_alloc_start;
|
2019-05-09 08:39:35 -07:00
|
|
|
else {
|
2019-05-17 06:51:16 -07:00
|
|
|
uintnat geom = mt_generate_geom();
|
2019-09-04 05:36:23 -07:00
|
|
|
if (Caml_state->young_ptr - Caml_state->young_alloc_start < geom)
|
2019-05-17 06:51:16 -07:00
|
|
|
/* No trigger in the current minor heap. */
|
2019-06-05 23:39:26 -07:00
|
|
|
caml_memprof_young_trigger = Caml_state->young_alloc_start;
|
2019-06-03 07:13:15 -07:00
|
|
|
caml_memprof_young_trigger = Caml_state->young_ptr - (geom - 1);
|
2019-05-09 08:39:35 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
caml_update_young_limit();
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Called when exceeding the threshold for the next sample in the
|
|
|
|
minor heap, from the C code (the handling is different when called
|
|
|
|
from natively compiled OCaml code). */
|
2020-01-07 04:30:26 -08:00
|
|
|
void caml_memprof_track_young(uintnat wosize, int from_caml,
|
|
|
|
int nallocs, unsigned char* encoded_alloc_lens)
|
2019-05-09 08:39:35 -07:00
|
|
|
{
|
2020-01-07 04:30:26 -08:00
|
|
|
uintnat whsize = Whsize_wosize(wosize);
|
|
|
|
value callstack, res = Val_unit;
|
|
|
|
int alloc_idx = 0, i, allocs_sampled = 0, has_delete = 0;
|
|
|
|
intnat alloc_ofs, trigger_ofs;
|
|
|
|
/* usually, only one allocation is sampled, even when the block contains
|
|
|
|
multiple combined allocations. So, we delay allocating the full
|
|
|
|
sampled_allocs array until we discover we actually need two entries */
|
|
|
|
uintnat first_idx, *idx_tab = &first_idx;
|
|
|
|
double saved_lambda = lambda;
|
2019-05-09 08:39:35 -07:00
|
|
|
|
2019-05-23 07:00:08 -07:00
|
|
|
if (caml_memprof_suspended) {
|
2019-05-09 08:39:35 -07:00
|
|
|
caml_memprof_renew_minor_sample();
|
2019-09-04 05:36:23 -07:00
|
|
|
return;
|
2019-05-09 08:39:35 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
/* If [lambda == 0], then [caml_memprof_young_trigger] should be
|
2019-06-05 23:39:26 -07:00
|
|
|
equal to [Caml_state->young_alloc_start]. But this function is only
|
|
|
|
called with [Caml_state->young_alloc_start <= Caml_state->young_ptr <
|
2019-05-09 08:39:35 -07:00
|
|
|
caml_memprof_young_trigger], which is contradictory. */
|
|
|
|
CAMLassert(lambda > 0);
|
|
|
|
|
2019-05-23 07:00:08 -07:00
|
|
|
if (!from_caml) {
|
2020-01-07 04:30:26 -08:00
|
|
|
unsigned n_samples = 1 +
|
|
|
|
mt_generate_binom(caml_memprof_young_trigger - 1 - Caml_state->young_ptr);
|
|
|
|
CAMLassert(encoded_alloc_lens == NULL); /* No Comballoc in C! */
|
2019-05-23 04:32:22 -07:00
|
|
|
caml_memprof_renew_minor_sample();
|
2019-09-04 05:36:23 -07:00
|
|
|
|
2020-01-21 06:34:28 -08:00
|
|
|
callstack = capture_callstack_postponed();
|
2019-09-04 05:36:23 -07:00
|
|
|
if (callstack == 0) return;
|
|
|
|
|
2020-01-10 06:51:03 -08:00
|
|
|
new_tracked(n_samples, wosize,
|
2019-09-04 05:36:23 -07:00
|
|
|
0, 1, Val_hp(Caml_state->young_ptr), callstack);
|
|
|
|
caml_memprof_check_action_pending();
|
|
|
|
return;
|
2019-05-23 04:32:22 -07:00
|
|
|
}
|
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
/* We need to call the callbacks for this sampled block. Since each
|
2019-05-09 08:39:35 -07:00
|
|
|
callback can potentially allocate, the sampled block will *not*
|
|
|
|
be the one pointed to by [caml_memprof_young_trigger]. Instead,
|
2019-05-23 04:32:22 -07:00
|
|
|
we remember that we need to sample the next allocated word,
|
2019-05-09 08:39:35 -07:00
|
|
|
call the callback and use as a sample the block which will be
|
|
|
|
allocated right after the callback. */
|
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
CAMLassert(Caml_state->young_ptr < caml_memprof_young_trigger &&
|
|
|
|
caml_memprof_young_trigger <= Caml_state->young_ptr + whsize);
|
|
|
|
trigger_ofs = caml_memprof_young_trigger - Caml_state->young_ptr;
|
|
|
|
alloc_ofs = whsize;
|
|
|
|
|
|
|
|
/* Restore the minor heap in a valid state for calling the callbacks.
|
2019-05-23 07:00:08 -07:00
|
|
|
We should not call the GC before these two instructions. */
|
2019-06-03 07:13:15 -07:00
|
|
|
Caml_state->young_ptr += whsize;
|
2019-05-09 08:39:35 -07:00
|
|
|
caml_memprof_renew_minor_sample();
|
2019-09-04 05:36:23 -07:00
|
|
|
caml_memprof_suspended = 1;
|
2020-01-07 04:30:26 -08:00
|
|
|
|
|
|
|
/* Perform the sampling of the block in the set of Comballoc'd
|
|
|
|
blocks, insert them in the entries array, and run the
|
|
|
|
callbacks. */
|
|
|
|
for (alloc_idx = nallocs - 1; alloc_idx >= 0; alloc_idx--) {
|
|
|
|
unsigned alloc_wosz = encoded_alloc_lens == NULL ? wosize :
|
|
|
|
Wosize_encoded_alloc_len(encoded_alloc_lens[alloc_idx]);
|
|
|
|
unsigned n_samples = 0;
|
|
|
|
alloc_ofs -= Whsize_wosize(alloc_wosz);
|
|
|
|
while (alloc_ofs < trigger_ofs) {
|
|
|
|
n_samples++;
|
|
|
|
trigger_ofs -= mt_generate_geom();
|
|
|
|
}
|
|
|
|
if (n_samples > 0) {
|
|
|
|
uintnat *idx_ptr, t_idx;
|
|
|
|
|
2020-01-14 07:29:17 -08:00
|
|
|
callstack = capture_callstack(alloc_idx);
|
2020-01-07 04:30:26 -08:00
|
|
|
t_idx = new_tracked(n_samples, alloc_wosz,
|
|
|
|
0, 1, Placeholder_offs(alloc_ofs), callstack);
|
|
|
|
if (t_idx == Invalid_index) continue;
|
|
|
|
res = handle_entry_callbacks_exn(&t_idx);
|
|
|
|
if (t_idx == Invalid_index) {
|
|
|
|
has_delete = 1;
|
|
|
|
if (saved_lambda != lambda) {
|
|
|
|
/* [lambda] changed during the callback. We need to refresh
|
|
|
|
[trigger_ofs]. */
|
|
|
|
saved_lambda = lambda;
|
|
|
|
trigger_ofs = lambda == 0. ? 0 : alloc_ofs - (mt_generate_geom() - 1);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if (Is_exception_result(res)) break;
|
|
|
|
if (t_idx == Invalid_index) continue;
|
|
|
|
|
|
|
|
if (allocs_sampled == 1) {
|
|
|
|
/* Found a second sampled allocation! Allocate a buffer for them */
|
|
|
|
idx_tab = caml_stat_alloc_noexc(sizeof(uintnat) * nallocs);
|
|
|
|
if (idx_tab == NULL) {
|
|
|
|
alloc_ofs = 0;
|
|
|
|
idx_tab = &first_idx;
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
idx_tab[0] = first_idx;
|
|
|
|
if (idx_tab[0] != Invalid_index)
|
|
|
|
trackst.entries[idx_tab[0]].idx_ptr = &idx_tab[0];
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Usually, trackst.entries[...].idx_ptr is owned by the thread
|
|
|
|
running a callback for the entry, if any. Here, we take ownership
|
|
|
|
of idx_ptr until the end of the function.
|
|
|
|
|
|
|
|
This does not conflict with the usual use of idx_ptr because no
|
|
|
|
callbacks can run on this entry until the end of the function:
|
|
|
|
the allocation callback has already run and the other callbacks
|
|
|
|
do not run on Placeholder values */
|
|
|
|
idx_ptr = &idx_tab[allocs_sampled];
|
|
|
|
*idx_ptr = t_idx;
|
|
|
|
trackst.entries[*idx_ptr].idx_ptr = idx_ptr;
|
|
|
|
allocs_sampled++;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
CAMLassert(alloc_ofs == 0 || Is_exception_result(res));
|
|
|
|
CAMLassert(allocs_sampled <= nallocs);
|
2019-09-04 05:36:23 -07:00
|
|
|
caml_memprof_suspended = 0;
|
|
|
|
caml_memprof_check_action_pending();
|
|
|
|
/* We need to call [caml_memprof_check_action_pending] since we
|
|
|
|
reset [caml_memprof_suspended] to 0 (a GC collection may have
|
|
|
|
triggered some new callback).
|
|
|
|
|
|
|
|
We need to make sure that the action pending flag is not set
|
|
|
|
systematically, which is to be expected, since [new_tracked]
|
|
|
|
created a new block without updating
|
|
|
|
[trackst.callback]. Fortunately, [handle_entry_callback_exn]
|
|
|
|
increments [trackst.callback] if it is equal to [t_idx]. */
|
2019-05-09 08:39:35 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
/* This condition happens either in the case of an exception or if
|
2020-01-07 04:30:26 -08:00
|
|
|
one of the callbacks returned [None]. If these cases happen
|
|
|
|
frequently, then we need to call [flush_deleted] somewhere to
|
|
|
|
prevent a leak. */
|
|
|
|
if (has_delete)
|
2019-09-04 05:36:23 -07:00
|
|
|
flush_deleted();
|
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
if (Is_exception_result(res)) {
|
|
|
|
for (i = 0; i < allocs_sampled; i++)
|
|
|
|
if (idx_tab[i] != Invalid_index) {
|
|
|
|
struct tracked* t = &trackst.entries[idx_tab[i]];
|
|
|
|
/* The allocations are cancelled because of the exception,
|
|
|
|
but this callback has already been called. We simulate a
|
|
|
|
deallocation. */
|
|
|
|
t->block = Val_unit;
|
|
|
|
t->deallocated = 1;
|
|
|
|
if (trackst.callback > idx_tab[i]) {
|
|
|
|
trackst.callback = idx_tab[i];
|
|
|
|
caml_memprof_check_action_pending();
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if (idx_tab != &first_idx) caml_stat_free(idx_tab);
|
|
|
|
caml_raise(Extract_exception(res));
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
|
2020-01-21 06:34:28 -08:00
|
|
|
/* We can now restore the minor heap in the state needed by
|
|
|
|
[Alloc_small_aux]. */
|
|
|
|
if (Caml_state->young_ptr - whsize < Caml_state->young_trigger) {
|
|
|
|
CAML_INSTR_INT("force_minor/memprof@", 1);
|
|
|
|
caml_gc_dispatch();
|
|
|
|
}
|
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
/* Re-allocate the blocks in the minor heap. We should not call the
|
2019-05-23 07:00:08 -07:00
|
|
|
GC after this. */
|
2019-06-03 07:13:15 -07:00
|
|
|
Caml_state->young_ptr -= whsize;
|
2019-05-09 08:39:35 -07:00
|
|
|
|
|
|
|
/* Make sure this block is not going to be sampled again. */
|
|
|
|
shift_sample(whsize);
|
|
|
|
|
2020-01-07 04:30:26 -08:00
|
|
|
for (i = 0; i < allocs_sampled; i++) {
|
|
|
|
if (idx_tab[i] != Invalid_index) {
|
|
|
|
/* If the execution of the callback has succeeded, then we start the
|
|
|
|
tracking of this block..
|
|
|
|
|
|
|
|
Subtlety: we are actually writing [t->block] with an invalid
|
|
|
|
(uninitialized) block. This is correct because the allocation
|
|
|
|
and initialization happens right after returning from
|
|
|
|
[caml_memprof_track_young]. */
|
|
|
|
struct tracked *t = &trackst.entries[idx_tab[i]];
|
|
|
|
t->block = Val_hp(Caml_state->young_ptr + Offs_placeholder(t->block));
|
|
|
|
t->idx_ptr = NULL;
|
|
|
|
CAMLassert(t->cb_alloc_called);
|
|
|
|
if (idx_tab[i] < trackst.young) trackst.young = idx_tab[i];
|
|
|
|
}
|
2019-05-09 08:39:35 -07:00
|
|
|
}
|
2020-01-07 04:30:26 -08:00
|
|
|
if (idx_tab != &first_idx) caml_stat_free(idx_tab);
|
2019-05-09 08:39:35 -07:00
|
|
|
|
2019-05-23 07:00:08 -07:00
|
|
|
/* /!\ Since the heap is in an invalid state before initialization,
|
|
|
|
very little heap operations are allowed until then. */
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
return;
|
2019-04-23 00:27:31 -07:00
|
|
|
}
|
2019-05-29 07:51:10 -07:00
|
|
|
|
|
|
|
void caml_memprof_track_interned(header_t* block, header_t* blockend) {
|
|
|
|
header_t *p;
|
|
|
|
value callstack = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
int is_young = Is_young(Val_hp(block));
|
2019-05-29 07:51:10 -07:00
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
if (lambda == 0 || caml_memprof_suspended)
|
2019-05-29 07:51:10 -07:00
|
|
|
return;
|
|
|
|
|
|
|
|
p = block;
|
2019-09-04 05:36:23 -07:00
|
|
|
while (1) {
|
2019-05-29 07:51:10 -07:00
|
|
|
uintnat next_sample = mt_generate_geom();
|
|
|
|
header_t *next_sample_p, *next_p;
|
2019-09-04 05:36:23 -07:00
|
|
|
if (next_sample > blockend - p)
|
2019-05-29 07:51:10 -07:00
|
|
|
break;
|
|
|
|
/* [next_sample_p] is the block *following* the next sampled
|
|
|
|
block! */
|
|
|
|
next_sample_p = p + next_sample;
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
while (1) {
|
2019-05-29 07:51:10 -07:00
|
|
|
next_p = p + Whsize_hp(p);
|
2019-09-04 05:36:23 -07:00
|
|
|
if (next_p >= next_sample_p) break;
|
2019-05-29 07:51:10 -07:00
|
|
|
p = next_p;
|
|
|
|
}
|
|
|
|
|
2020-01-21 06:34:28 -08:00
|
|
|
if (callstack == 0) callstack = capture_callstack_postponed();
|
2019-09-04 05:36:23 -07:00
|
|
|
if (callstack == 0) break; /* OOM */
|
|
|
|
new_tracked(mt_generate_binom(next_p - next_sample_p) + 1,
|
2020-01-10 06:51:03 -08:00
|
|
|
Wosize_hp(p), 1, is_young, Val_hp(p), callstack);
|
2019-05-29 07:51:10 -07:00
|
|
|
p = next_p;
|
|
|
|
}
|
2019-09-04 05:36:23 -07:00
|
|
|
caml_memprof_check_action_pending();
|
|
|
|
}
|
|
|
|
|
|
|
|
/**** Interface with the OCaml code. ****/
|
|
|
|
|
|
|
|
static void caml_memprof_init(void) {
|
|
|
|
uintnat i;
|
|
|
|
|
|
|
|
init = 1;
|
|
|
|
|
|
|
|
mt_index = MT_STATE_SIZE;
|
|
|
|
mt_state[0] = 42;
|
|
|
|
for (i = 1; i < MT_STATE_SIZE; i++)
|
|
|
|
mt_state[i] = 0x6c078965 * (mt_state[i-1] ^ (mt_state[i-1] >> 30)) + i;
|
|
|
|
}
|
|
|
|
|
|
|
|
void caml_memprof_shutdown(void) {
|
|
|
|
init = 0;
|
2020-01-10 07:59:20 -08:00
|
|
|
started = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
lambda = 0.;
|
|
|
|
caml_memprof_suspended = 0;
|
|
|
|
trackst.len = 0;
|
|
|
|
trackst.callback = trackst.young = trackst.delete = 0;
|
|
|
|
caml_stat_free(trackst.entries);
|
|
|
|
trackst.entries = NULL;
|
|
|
|
trackst.alloc_len = 0;
|
2020-02-03 06:45:34 -08:00
|
|
|
caml_stat_free(callstack_buffer);
|
|
|
|
callstack_buffer = NULL;
|
|
|
|
callstack_buffer_len = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
}
|
|
|
|
|
Gc.Memprof.start: take a record instead of 5 optional parameters
The Gc.Memprof module provides a low-level API, that will hopefully be
paired with user libraries that provide high-level instrumentation
choices.
A natural question is: how are the higher-level API going to expose
their choice of instrumentation to their users? With the current
Memprof.start API (before this patch), they would have to either
provide their own `start` function wrapping Memprof.start, or provide
a tuple of callbacks for to their users to pass to Memprof.start
themselves.
val start : params -> unit
(* or *)
val callback : params ->
((allocation -> foo option) * (allocation -> bar option) * ... )
With an explicit record, it is easier for libraries to expose an
instrumentation choice (possibility parametrized over
user-provided settings):
val tracker : params -> (foo, bar) Gc.Memprof.tracker
In addition, providing a record instead of optional parameters makes
it much easier to provide "default settings" (helper functions) that
instantiates the types `'minor` and `'ḿajor`, see for example
`simple_tracker` in this patch (which stores the same information for
the minor and major heap, and does not observe promotion), or to later
define checking predicates that can verify that a given choice of
callbacks is sensible (for example: providing a major-dealloc callback
but no promotion callback (dropping all tracked value on promotion) is
probably not a good idea).
Bootstrap: to avoid requiring an awkward bootstrap, this commit keeps
the (now unused) function caml_memprof_start_byt unchanged -- it is
used in the bootstrap binaries, so removing it would break the
build. The intention is to remove it in the following commit.
2020-01-21 12:42:03 -08:00
|
|
|
CAMLprim value caml_memprof_start(value lv, value szv, value tracker)
|
2019-09-04 05:36:23 -07:00
|
|
|
{
|
Gc.Memprof.start: take a record instead of 5 optional parameters
The Gc.Memprof module provides a low-level API, that will hopefully be
paired with user libraries that provide high-level instrumentation
choices.
A natural question is: how are the higher-level API going to expose
their choice of instrumentation to their users? With the current
Memprof.start API (before this patch), they would have to either
provide their own `start` function wrapping Memprof.start, or provide
a tuple of callbacks for to their users to pass to Memprof.start
themselves.
val start : params -> unit
(* or *)
val callback : params ->
((allocation -> foo option) * (allocation -> bar option) * ... )
With an explicit record, it is easier for libraries to expose an
instrumentation choice (possibility parametrized over
user-provided settings):
val tracker : params -> (foo, bar) Gc.Memprof.tracker
In addition, providing a record instead of optional parameters makes
it much easier to provide "default settings" (helper functions) that
instantiates the types `'minor` and `'ḿajor`, see for example
`simple_tracker` in this patch (which stores the same information for
the minor and major heap, and does not observe promotion), or to later
define checking predicates that can verify that a given choice of
callbacks is sensible (for example: providing a major-dealloc callback
but no promotion callback (dropping all tracked value on promotion) is
probably not a good idea).
Bootstrap: to avoid requiring an awkward bootstrap, this commit keeps
the (now unused) function caml_memprof_start_byt unchanged -- it is
used in the bootstrap binaries, so removing it would break the
build. The intention is to remove it in the following commit.
2020-01-21 12:42:03 -08:00
|
|
|
CAMLparam3(lv, szv, tracker);
|
|
|
|
|
2019-09-04 05:36:23 -07:00
|
|
|
double l = Double_val(lv);
|
|
|
|
intnat sz = Long_val(szv);
|
2020-01-10 07:59:20 -08:00
|
|
|
|
Gc.Memprof.start: take a record instead of 5 optional parameters
The Gc.Memprof module provides a low-level API, that will hopefully be
paired with user libraries that provide high-level instrumentation
choices.
A natural question is: how are the higher-level API going to expose
their choice of instrumentation to their users? With the current
Memprof.start API (before this patch), they would have to either
provide their own `start` function wrapping Memprof.start, or provide
a tuple of callbacks for to their users to pass to Memprof.start
themselves.
val start : params -> unit
(* or *)
val callback : params ->
((allocation -> foo option) * (allocation -> bar option) * ... )
With an explicit record, it is easier for libraries to expose an
instrumentation choice (possibility parametrized over
user-provided settings):
val tracker : params -> (foo, bar) Gc.Memprof.tracker
In addition, providing a record instead of optional parameters makes
it much easier to provide "default settings" (helper functions) that
instantiates the types `'minor` and `'ḿajor`, see for example
`simple_tracker` in this patch (which stores the same information for
the minor and major heap, and does not observe promotion), or to later
define checking predicates that can verify that a given choice of
callbacks is sensible (for example: providing a major-dealloc callback
but no promotion callback (dropping all tracked value on promotion) is
probably not a good idea).
Bootstrap: to avoid requiring an awkward bootstrap, this commit keeps
the (now unused) function caml_memprof_start_byt unchanged -- it is
used in the bootstrap binaries, so removing it would break the
build. The intention is to remove it in the following commit.
2020-01-21 12:42:03 -08:00
|
|
|
value cb_alloc_minor = Field(tracker, 0);
|
|
|
|
value cb_alloc_major = Field(tracker, 1);
|
|
|
|
value cb_promote = Field(tracker, 2);
|
|
|
|
value cb_dealloc_minor = Field(tracker, 3);
|
|
|
|
value cb_dealloc_major = Field(tracker, 4);
|
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
if (started) caml_failwith("Gc.Memprof.start: already started.");
|
2019-09-04 05:36:23 -07:00
|
|
|
|
|
|
|
if (sz < 0 || !(l >= 0.) || l > 1.) /* Checks that [l] is not NAN. */
|
2020-01-10 07:59:20 -08:00
|
|
|
caml_invalid_argument("Gc.Memprof.start");
|
2019-09-04 05:36:23 -07:00
|
|
|
|
|
|
|
if (!init) caml_memprof_init();
|
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
lambda = l;
|
|
|
|
if (l > 0) {
|
|
|
|
one_log1m_lambda = l == 1 ? 0 : 1/caml_log1p(-l);
|
|
|
|
next_mt_generate_geom = mt_generate_geom();
|
|
|
|
}
|
|
|
|
|
|
|
|
caml_memprof_renew_minor_sample();
|
|
|
|
|
|
|
|
callstack_size = sz;
|
|
|
|
started = 1;
|
|
|
|
|
|
|
|
|
|
|
|
callback_alloc_minor = cb_alloc_minor;
|
|
|
|
callback_alloc_major = cb_alloc_major;
|
|
|
|
callback_promote = cb_promote;
|
|
|
|
callback_dealloc_minor = cb_dealloc_minor;
|
|
|
|
callback_dealloc_major = cb_dealloc_major;
|
|
|
|
|
|
|
|
caml_register_generational_global_root(&callback_alloc_minor);
|
|
|
|
caml_register_generational_global_root(&callback_alloc_major);
|
|
|
|
caml_register_generational_global_root(&callback_promote);
|
|
|
|
caml_register_generational_global_root(&callback_dealloc_minor);
|
|
|
|
caml_register_generational_global_root(&callback_dealloc_major);
|
|
|
|
|
|
|
|
CAMLreturn(Val_unit);
|
|
|
|
}
|
|
|
|
|
|
|
|
CAMLprim value caml_memprof_stop(value unit)
|
|
|
|
{
|
|
|
|
uintnat i;
|
|
|
|
|
|
|
|
if (!started) caml_failwith("Gc.Memprof.stop: not started.");
|
|
|
|
|
|
|
|
/* This call to [caml_memprof_stop] will discard all the previously
|
2019-09-04 05:36:23 -07:00
|
|
|
tracked blocks. We try one last time to call the postponed
|
|
|
|
callbacks. */
|
|
|
|
caml_raise_if_exception(caml_memprof_handle_postponed_exn());
|
|
|
|
|
|
|
|
/* Discard the tracked blocks. */
|
|
|
|
for (i = 0; i < trackst.len; i++)
|
|
|
|
if (trackst.entries[i].idx_ptr != NULL)
|
|
|
|
*trackst.entries[i].idx_ptr = Invalid_index;
|
|
|
|
trackst.len = 0;
|
|
|
|
trackst.callback = trackst.young = trackst.delete = 0;
|
|
|
|
caml_stat_free(trackst.entries);
|
|
|
|
trackst.entries = NULL;
|
|
|
|
trackst.alloc_len = 0;
|
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
lambda = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
caml_memprof_renew_minor_sample();
|
2020-01-10 07:59:20 -08:00
|
|
|
started = 0;
|
2019-09-04 05:36:23 -07:00
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
caml_remove_generational_global_root(&callback_alloc_minor);
|
|
|
|
caml_remove_generational_global_root(&callback_alloc_major);
|
|
|
|
caml_remove_generational_global_root(&callback_promote);
|
|
|
|
caml_remove_generational_global_root(&callback_dealloc_minor);
|
|
|
|
caml_remove_generational_global_root(&callback_dealloc_major);
|
2019-09-04 05:36:23 -07:00
|
|
|
|
2020-01-29 09:14:05 -08:00
|
|
|
caml_stat_free(callstack_buffer);
|
|
|
|
callstack_buffer = NULL;
|
|
|
|
callstack_buffer_len = 0;
|
|
|
|
|
2020-01-10 07:59:20 -08:00
|
|
|
return Val_unit;
|
2019-05-29 07:51:10 -07:00
|
|
|
}
|