lumbda/c/gc.c

/*
 * gc.c — precise tracing for NaN-boxed Values under Boehm GC.
 *
 * Boehm's conservative scan treats every machine word as a maybe-pointer:
 * if its bit pattern looks like a heap address, the target stays alive.
 * Lumbda's Values are NaN-boxed — pointers live in the low 48 bits with
 * tag bits in the upper mantissa, so the raw word never looks like a
 * pointer to Boehm. Live Pairs, Strings, Procs, etc. get reclaimed mid
 * iteration unless we tell Boehm how to walk our Value-bearing buffers.
 *
 * We register a custom mark kind. Any allocation that carries Values goes
 * through lumbda_value_malloc — Boehm tracks the kind on the block & calls
 * our mark proc when it scans the block. Our proc walks 8-byte words,
 * decodes the tag, & pushes the underlying pointer for each Value whose
 * tag identifies a pointer-bearing type.
 *
 * Pure-byte allocations (strings, bignum limbs, symbol names) stay on the
 * normal GC_MALLOC path — Boehm scans them as plain pointers correctly.
 */

#ifdef USE_BOEHM_GC

#include "lumbda.h"
#include <gc.h>
#include <gc/gc_mark.h>

int lumbda_value_kind = -1;
static void *lumbda_value_free_list = NULL;

/* Stack root scanning: Boehm's conservative scan over the C stack sees
 * raw 8-byte words & accepts those that fall inside heap bounds. A
 * NaN-boxed Value living in a C local has its high bits set (QNAN
 * pattern) so the raw word does NOT look like a valid heap address &
 * Boehm skips it — the underlying object dies even though the C frame
 * still holds the Value. We add a second pass via push_other_roots:
 * walk the same stack range Boehm already tracks, decode any NaN-boxed
 * Value & push its low-48 payload as a root. main() captures the stack
 * base at process start; the current SP comes from setjmp inside the
 * callback. */
static void *g_stack_base = NULL;
static GC_push_other_roots_proc g_prev_push_other_roots = NULL;

static void lumbda_push_other_roots(void) {
    if (g_prev_push_other_roots) g_prev_push_other_roots();
    if (!g_stack_base) return;
    /* setjmp serves only to anchor an address (&snap) inside our own
     * frame — the actual stack walk runs from there up to g_stack_base,
     * so it covers every C frame above us at the moment GC fired. Lisp
     * Values held in caller-saved regs are spilled to memory by callers
     * around any GC-triggering call (cons → make_pair → ul_malloc_values),
     * so the stack walk catches them too. */
    jmp_buf snap;
    setjmp(snap);
    Value *sp = (Value *)&snap;
    Value *base = (Value *)g_stack_base;
    if (sp > base) { Value *t = sp; sp = base; base = t; }
    for (Value *p = sp; p < base; p++) {
        Value v = *p;
        if ((v & QNAN) != QNAN) continue;
        uint64_t tag = (v >> TAG_SHIFT) & 7ULL;
        if (tag == TAG_INT || tag == TAG_SPECIAL) continue;
        void *ptr = (void *)(uintptr_t)(v & PAYLOAD_MASK);
        if (!ptr) continue;
        /* GC_push_all_eager marks the location immediately rather than
         * deferring to the regular mark stack — safe to point at a
         * stack-local since the mark happens before we return. */
        GC_push_all_eager(&ptr, (char *)&ptr + sizeof(void *));
    }
}

void lumbda_gc_set_stack_base(void *base) { g_stack_base = base; }

/*
 * Mark proc: scan a block of memory containing a mix of NaN-boxed Values
 * & plain pointer fields (struct headers, embedded raw pointers).
 *
 * `addr` points at the head of the block. `GC_size(addr)` gives the block
 * size in bytes. We treat the block as an array of 8-byte words & decode
 * each one in two passes:
 *
 *   1. NaN-boxed pointer Value: upper QNAN bits set, tag ∈
 *      {PTR(0), SYM(2), BUILTIN(4), RATIONAL(5), BIGNUM(6)}. Extract the
 *      low 48 bits as the pointer & push that.
 *   2. Plain raw pointer: anything else. Push the word as-is —
 *      GC_MARK_AND_PUSH validates against heap bounds, so ints, enums,
 *      fixnums, etc. fall outside & are silently skipped.
 *
 * Heap addresses on Linux user-space sit below 2^47, so bits 48..63 of a
 * plain pointer are zero — `(ptr & QNAN) == 0 != QNAN`, never confused
 * with a NaN-boxed Value. Inversely, a NaN-boxed pointer has bits 48..62
 * set & its low 48 hold the real address; treating the raw word as a
 * pointer in pass 2 would walk into nowhere (heap base + tag bits = bad
 * address that fails the heap-bounds check anyway).
 *
 * This makes the precise kind safe for ANY struct (header + Values +
 * raw pointers) — strictly a superset of what conservative NORMAL kind
 * would catch, plus precise NaN-box decoding.
 */
struct GC_ms_entry *
mark_lumbda_value_block(GC_word *addr,
                        struct GC_ms_entry *mark_stack_ptr,
                        struct GC_ms_entry *mark_stack_limit,
                        GC_word env) {
    (void)env;
    size_t bytes = GC_size((const void *)addr);
    size_t nwords = bytes / sizeof(Value);
    Value *p = (Value *)addr;
    for (size_t i = 0; i < nwords; i++) {
        Value v = p[i];
        if ((v & QNAN) == QNAN) {
            uint64_t tag = (v >> TAG_SHIFT) & 7ULL;
            if (tag == TAG_INT || tag == TAG_SPECIAL) continue;
            /* NaN-boxed pointer-bearing tag — decode low 48 bits. */
            void *ptr = (void *)(uintptr_t)(v & PAYLOAD_MASK);
            if (!ptr) continue;
            mark_stack_ptr = GC_MARK_AND_PUSH(ptr,
                                              mark_stack_ptr,
                                              mark_stack_limit,
                                              (void **)&p[i]);
        } else {
            /* Not NaN-boxed: treat as raw pointer (or non-pointer int that
             * the heap-bounds check inside GC_MARK_AND_PUSH will reject). */
            mark_stack_ptr = GC_MARK_AND_PUSH((void *)(uintptr_t)v,
                                              mark_stack_ptr,
                                              mark_stack_limit,
                                              (void **)&p[i]);
        }
    }
    return mark_stack_ptr;
}

void lumbda_gc_init(void) {
    if (lumbda_value_kind != -1) return;
    int proc_idx = GC_new_proc(mark_lumbda_value_block);
    /* GC_new_kind(free_list, mark_descriptor, add_size_to_descriptor,
     *             clear_new_objects)
     *   - mark_descriptor: GC_MAKE_PROC(proc_idx, 0) — call our proc.
     *   - add_size_to_descriptor: 0 — DS_PROC descriptors do not survive
     *     the bdwgc per-object `descr += sz` adjustment; bytes would
     *     overflow into proc_idx bits & dispatch through a NULL proc
     *     slot. The proc derives size via GC_size(addr) instead.
     *   - clear_new_objects: 1 — zero-init so we never decode garbage as
     *     a stale pointer before the caller writes the first Value. */
    lumbda_value_kind = GC_new_kind(&lumbda_value_free_list,
                                    GC_MAKE_PROC(proc_idx, 0),
                                    0, 1);
    g_prev_push_other_roots = GC_get_push_other_roots();
    GC_set_push_other_roots(lumbda_push_other_roots);
}


void *lumbda_value_malloc(size_t sz) {
    if (lumbda_value_kind == -1) lumbda_gc_init();
    return GC_generic_malloc(sz, lumbda_value_kind);
}

#else /* !USE_BOEHM_GC */

#include "lumbda.h"

int lumbda_value_kind = -1;

void lumbda_gc_init(void) { /* no-op */ }
void lumbda_gc_set_stack_base(void *base) { (void)base; }

void *lumbda_value_malloc(size_t sz) {
    return malloc(sz);
}

#endif