path: root/cbits/hook.c

#include "Rts.h"
#include <string.h>
#include <time.h>

// needs C11
#include <threads.h>

static size_t min_sz(size_t a, size_t b) {
	return a < b ? a : b;
}

extern RtsConfig __attribute__((weak)) rtsConfig;

// A copy of GCDetails_ with known structure that can be depended on by the Haskell code.
struct ShadowDetails {
	int64_t timestamp_sec;
	int64_t timestamp_nsec;

	// The generation number of this GC
	uint32_t gen;
	// Number of threads used in this GC
	uint32_t threads;
	// Number of bytes allocated since the previous GC
	uint64_t allocated_bytes;
	// Total amount of live data in the heap (incliudes large + compact data).
	// Updated after every GC. Data in uncollected generations (in minor GCs)
	// are considered live.
	uint64_t live_bytes;
	// Total amount of live data in large objects
	uint64_t large_objects_bytes;
	// Total amount of live data in compact regions
	uint64_t compact_bytes;
	// Total amount of slop (wasted memory)
	uint64_t slop_bytes;
	// Total amount of memory in use by the RTS
	uint64_t mem_in_use_bytes;
	// Total amount of data copied during this GC
	uint64_t copied_bytes;
	// In parallel GC, the max amount of data copied by any one thread
	uint64_t par_max_copied_bytes;
	// In parallel GC, the amount of balanced data copied by all threads
	uint64_t par_balanced_copied_bytes;
	// The time elapsed during synchronisation before GC
	// NOTE: nanoseconds!
	uint64_t sync_elapsed_ns;
	// The CPU time used during GC itself
	// NOTE: nanoseconds!
	uint64_t cpu_ns;
	// The time elapsed during GC itself
	// NOTE: nanoseconds!
	uint64_t elapsed_ns;

	// Concurrent garbage collector

	// The CPU time used during the post-mark pause phase of the concurrent
	// nonmoving GC.
	// NOTE: nanoseconds!
	uint64_t nonmoving_gc_sync_cpu_ns;
	// The time elapsed during the post-mark pause phase of the concurrent
	// nonmoving GC.
	// NOTE: nanoseconds!
	uint64_t nonmoving_gc_sync_elapsed_ns;
	// The CPU time used during the post-mark pause phase of the concurrent
	// nonmoving GC.
	// NOTE: nanoseconds!
	uint64_t nonmoving_gc_cpu_ns;
	// The time elapsed during the post-mark pause phase of the concurrent
	// nonmoving GC.
	// NOTE: nanoseconds!
	uint64_t nonmoving_gc_elapsed_ns;
};

static void shadow_copy(struct ShadowDetails *dst, const struct GCDetails_ *src) {
#define COPY(field) dst->field = src->field;
#define COPYTIME(field) dst->field = TimeToNS(src->field);
	COPY(gen);
	COPY(threads);
	COPY(allocated_bytes);
	COPY(live_bytes);
	COPY(large_objects_bytes);
	COPY(compact_bytes);
	COPY(slop_bytes);
	COPY(mem_in_use_bytes);
	COPY(copied_bytes);
	COPY(par_max_copied_bytes);
	COPY(par_balanced_copied_bytes);
	COPYTIME(sync_elapsed_ns);
	COPYTIME(cpu_ns);
	COPYTIME(elapsed_ns);

	COPYTIME(nonmoving_gc_sync_cpu_ns);
	COPYTIME(nonmoving_gc_sync_elapsed_ns);
	COPYTIME(nonmoving_gc_cpu_ns);
	COPYTIME(nonmoving_gc_elapsed_ns);
#undef COPY
#undef COPYTIME
}

// --------
// GLOBAL VARIABLES
// --------

static bool constructor_worked = false;
static bool hook_initialised = false;
static bool logging_enabled = false;
static void (*hook_c_delegate)(const struct GCDetails_*) = NULL;

static mtx_t state_mutex;

static void (*old_hook)(const struct GCDetails_ *details) = NULL;
static size_t detlog_capacity = 0, detlog_length = 0;
static struct ShadowDetails *detlog = NULL;

// --------
// END OF GLOBAL VARIABLES
// --------

static void hook_callback(const struct GCDetails_ *details) {
	static bool fatal_failure = false;

	if (fatal_failure) goto cleanup_no_mutex;

	// Do this now already, before waiting on the mutex
	struct timespec now;
	if (logging_enabled && clock_gettime(CLOCK_MONOTONIC, &now) != 0) {
		perror("clock_gettime");
		fatal_failure = true;
		goto cleanup_no_mutex;
	}

	if (mtx_lock(&state_mutex) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
		fatal_failure = true;
		goto cleanup_no_mutex;
	}

	// mutex is locked from here

	if (logging_enabled) {
		if (detlog_length == detlog_capacity) {
			detlog_capacity = detlog_capacity == 0 ? 128 : 2 * detlog_capacity;
			detlog = realloc(detlog, detlog_capacity * sizeof(detlog[0]));
			if (detlog == NULL || detlog_capacity == 0) {  // also check for overflow here
				fprintf(stderr, "ghc-gc-hook: ERROR: Could not allocate memory for GC log hook\n");
				fatal_failure = true;
				goto cleanup;
			}
		}

		struct ShadowDetails *dst = &detlog[detlog_length];
		dst->timestamp_sec = now.tv_sec;
		dst->timestamp_nsec = now.tv_nsec;
		shadow_copy(dst, details);
		detlog_length++;
	}

	if (hook_c_delegate) hook_c_delegate(details);

cleanup:
	mtx_unlock(&state_mutex);  // ignore return value

cleanup_no_mutex:
	if (old_hook) old_hook(details);
}

__attribute__((constructor))
static void constructor(void) {
	if (mtx_init(&state_mutex, mtx_plain) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex initialisation failed\n");
		return;
	}

	constructor_worked = true;
}

// --------
// EXPORTED FUNCTIONS
// --------

// Only works if logging is enabled.
void copy_log_to_buffer(size_t space_available, char *buffer, size_t *unit_size, size_t *num_stored) {
	*unit_size = sizeof(detlog[0]);

	if (mtx_lock(&state_mutex) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
		*num_stored = 0;
		return;
	}

	if (detlog_length == 0) {
		*num_stored = 0;
		goto unlock_return;
	}

	const size_t n = min_sz(space_available / sizeof(detlog[0]), detlog_length);

	// First copy over the fitting items
	memcpy(buffer, detlog, n * sizeof(detlog[0]));
	*unit_size = sizeof(detlog[0]);
	*num_stored = n;

	// Then shift back the remaining items
	memmove(detlog, detlog + n, (detlog_length - n) * sizeof(detlog[0]));
	detlog_length -= n;

unlock_return:
	mtx_unlock(&state_mutex);
}

// Sets the GC hook, logging or C hook delegate not yet enabled. Returns success.
bool set_gchook(void) {
	if (mtx_lock(&state_mutex) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
		return false;
	}

	bool retval = false;

	if (!constructor_worked) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Cannot set hook, system does not allow initialisation\n");
		goto unlock_return_retval;
	}

	if (hook_initialised) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Hook already initialised\n");
		goto unlock_return_retval;
	}

	if (&rtsConfig == NULL) {
		fprintf(stderr, "ghc-gc-hook: ERROR: rtsConfig not defined; the GC hook cannot be used from within a TemplateHaskell splice\n");
		goto unlock_return_retval;
	}

	old_hook = rtsConfig.gcDoneHook;
	rtsConfig.gcDoneHook = hook_callback;

	hook_initialised = true;
	retval = true;

unlock_return_retval:
	mtx_unlock(&state_mutex);
	return retval;
}

// Enable logging on the GC hook.
void gchook_enable_logging(bool yes) {
	if (!hook_initialised) {
		if (!set_gchook()) exit(1);  // meh
	}

	if (mtx_lock(&state_mutex) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
		return;
	}

	if (logging_enabled && !yes) {
		detlog_length = 0;
		detlog_capacity = 0;
		free(detlog);
		detlog = NULL;
	}

	logging_enabled = yes;

	mtx_unlock(&state_mutex);
}

// Set a C function to be called after every GC with the GCDetails_ structure
// from `rts/include/RtsAPI.h`. Returns success.
bool gchook_set_c_delegate(void (*delegate)(const struct GCDetails_*)) {
	if (!hook_initialised) {
		if (!set_gchook()) exit(1);  // meh
	}

	if (mtx_lock(&state_mutex) != thrd_success) {
		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
		return false;
	}

	bool retval = false;

	if (hook_c_delegate != NULL) {
		fprintf(stderr, "ghc-gc-hook: ERROR: C hook delegate already set\n");
		goto unlock_return_retval;
	}

	hook_c_delegate = delegate;
	retval = true;

unlock_return_retval:
	mtx_unlock(&state_mutex);
	return retval;
}

// vim: set noet sw=4 ts=4: