#include "Rts.h" #include #include // needs C11 #include 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: