code_object.c

/**
 * @file code_object.c
 * @brief Code object management and GC integration
 *
 * This file manages compiled code objects - their creation, destruction,
 * and integration with the garbage collector.
 *
 * ## Code Object Lifecycle
 * 1. code_new() creates a new code object and registers it with GC
 * 2. Compiler fills in bytecode, constants, and children
 * 3. GC updates constants during collection (gc_update_all_code_objects)
 * 4. gc_sweep_code_objects() frees unreachable code objects
 */

#include "bytecode.h"
#include "compile_internal.h"
#include "context.h"
#include <stdint.h>
#include <stdlib.h>

// ============================================================================
// Code Object Registry
// ============================================================================

// Global registry of all code objects for GC integration
code_object *code_object_registry = NULL;

// Membership set over the same objects. The list above is what the GC walks;
// this answers "is this pointer a live code object" without walking it.
// That question is asked on every call to a bytecode closure - it is how a
// corrupt cell is stopped from being dereferenced as a code object - and as a
// list walk it cost time proportional to how early the callee was defined,
// since registration prepends. Measured at 2M calls: 9.7s for a procedure
// defined early in stdlib.scm against 2.2s for one defined late.
static code_object **code_set;
static size_t code_set_cap;      // power of two, 0 until first use
static size_t code_set_used;     // live entries
static size_t code_set_occupied; // live entries plus tombstones
// Set when an allocation failure left a registered object out of the table.
// While it is set the table is missing entries, so it cannot answer "no" -
// lookups fall back to the registry list until a rebuild succeeds.
static bool code_set_incomplete;
#define CODE_SET_TOMBSTONE ((code_object *)(uintptr_t)1)

static size_t code_set_start(size_t cap, const code_object *code)
{
    uintptr_t v = (uintptr_t)code >> 4;
    v *= 0x9E3779B97F4A7C15ull;
    return (size_t)v & (cap - 1);
}

// Insert position: a tombstone is a fine place to land.
static size_t code_set_slot_insert(code_object **table, size_t cap,
                                   const code_object *code)
{
    size_t i = code_set_start(cap, code);
    while (table[i] && table[i] != CODE_SET_TOMBSTONE && table[i] != code)
        i = (i + 1) & (cap - 1);
    return i;
}

// Lookup position: a tombstone must NOT stop the probe, or an entry inserted
// after one was created becomes invisible - which reports a live code object
// as unregistered and fails every call into it.
static size_t code_set_slot_find(code_object **table, size_t cap,
                                 const code_object *code)
{
    size_t i = code_set_start(cap, code);
    while (table[i] && table[i] != code)
        i = (i + 1) & (cap - 1);
    return i;
}

static bool code_set_alloc_always_fails;

void code_set_force_alloc_failure(bool fail)
{
    code_set_alloc_always_fails = fail;
}

// Rebuild the table from code_object_registry, not from the old table. The
// list is the authoritative membership: code_register puts an object on it
// before adding to the set, and code_unregister removes from both. Rebuilding
// from the list is therefore identical in the ordinary case, and it is what
// lets a table that lost entries to a failed allocation heal - rehashing the
// old table would only carry the loss forward.
static bool code_set_grow(void)
{
    size_t live = 0;
    for (const code_object *c = code_object_registry; c; c = c->gc_next)
        live++;
    size_t cap = code_set_cap ? code_set_cap : 256;
    while (cap < (live + 1) * 2)
        cap *= 2;
    code_object **table =
        code_set_alloc_always_fails ? NULL : calloc(cap, sizeof(code_object *));
    if (!table)
        return false;
    for (code_object *c = code_object_registry; c; c = c->gc_next)
        table[code_set_slot_insert(table, cap, c)] = c;
    free(code_set);
    code_set = table;
    code_set_cap = cap;
    code_set_used = live;
    code_set_occupied = live; // rehashing drops the tombstones
    code_set_incomplete = false;
    return true;
}

static void code_set_add(code_object *code)
{
    // Tombstones count here, not just live entries. A long session registers
    // and sweeps code objects continuously; if only live entries were counted
    // the table would never rehash, tombstones would fill every slot, and the
    // lookup probe - which cannot stop at one - would spin forever looking for
    // an empty slot that no longer exists.
    // A previous failure leaves entries missing, so keep retrying the rebuild
    // until one succeeds; nothing else restores them.
    if (code_set_incomplete || code_set_occupied + 1 > code_set_cap / 2) {
        if (!code_set_grow()) {
            // The caller has already put this object on the registry list, so
            // it stays reachable, but the table no longer mirrors that list.
            code_set_incomplete = true;
            return;
        }
    }
    size_t i = code_set_slot_insert(code_set, code_set_cap, code);
    if (code_set[i] == code)
        return;
    if (!code_set[i])
        code_set_occupied++; // an empty slot, not a reused tombstone
    code_set[i] = code;
    code_set_used++;
}

static void code_set_remove(const code_object *code)
{
    if (!code_set_cap)
        return;
    size_t i = code_set_slot_find(code_set, code_set_cap, code);
    if (code_set[i] == code) {
        code_set[i] = CODE_SET_TOMBSTONE;
        code_set_used--;
    }
}

// Register a code object with the GC registry
void code_register(code_object *code)
{
    if (!code || code_object_is_registered(code))
        return;
    code->gc_next = code_object_registry;
    code_object_registry = code;
    code_set_add(code);
}

static void code_unregister(code_object *code)
{
    code_object **prev = &code_object_registry;
    while (*prev) {
        if (*prev == code) {
            *prev = code->gc_next;
            code->gc_next = NULL;
            code_set_remove(code);
            return;
        }
        prev = &(*prev)->gc_next;
    }
}

static bool code_arrays_well_formed(const code_object *code)
{
    return code && code->code_len <= code->code_cap &&
           code->const_len <= code->const_cap &&
           code->children_len <= code->children_cap &&
           (code->code_len == 0 || code->code != NULL) &&
           (code->const_len == 0 || code->constants != NULL) &&
           (code->children_len == 0 || code->children != NULL);
}

// A child can be shared by more than one code object (the public code-object
// API permits DAGs, not just trees).  Only release it once no registered
// parent still owns a reference to it.
static bool code_has_registered_parent(const code_object *child)
{
    for (code_object *parent = code_object_registry; parent;
         parent = parent->gc_next) {
        if (!code_arrays_well_formed(parent))
            continue;
        for (unsigned i = 0; i < parent->children_len; i++) {
            if (parent->children[i] == child)
                return true;
        }
    }
    return false;
}

// ============================================================================
// Code Object Creation and Destruction
// ============================================================================

static void code_destroy_shallow(code_object *code)
{
    if (!code)
        return;
    free(code->code);
    free(code->constants);
    free(code->children);
    free(code);
}

code_object *code_new(void)
{
    code_object *c = checked_calloc_array(1, sizeof(code_object));
    if (!c)
        return NULL;

    c->code_cap = 64;
    c->code = checked_malloc_array(c->code_cap, sizeof(unsigned));
    if (!c->code) {
        code_destroy_shallow(c);
        return NULL;
    }

    c->const_cap = 16;
    c->constants = checked_malloc_array(c->const_cap, sizeof(unsigned));
    if (!c->constants) {
        code_destroy_shallow(c);
        return NULL;
    }

    c->children_cap = 4;
    c->children = checked_malloc_array(c->children_cap, sizeof(code_object *));
    if (!c->children) {
        code_destroy_shallow(c);
        return NULL;
    }

    // Register with GC
    code_register(c);
    return c;
}

void code_free(code_object *code)
{
    if (!code || !code_object_is_registered(code))
        return;
    code_unregister(code);
    if (code->children_len <= code->children_cap && code->children) {
        for (unsigned i = 0; i < code->children_len; i++) {
            code_object *child = code->children[i];
            if (!code_has_registered_parent(child))
                code_free(child);
        }
    }
    code_destroy_shallow(code);
}

// ============================================================================
// Code Object Mutation
// ============================================================================

void code_emit(code_object *code, unsigned instr)
{
    if (!code)
        lisp_panic("code_emit: null code object");
    code->verified = false;
    if (code->code_len >= code->code_cap) {
        unsigned new_cap =
            checked_grow_capacity(code->code_cap, sizeof(unsigned),
                                  "code_emit: capacity overflow");
        unsigned *new_code =
            checked_realloc_array(code->code, new_cap, sizeof(unsigned));
        if (!new_code) {
            lisp_panic("code_emit: realloc failed");
        }
        code->code = new_code;
        code->code_cap = new_cap;
    }
    code->code[code->code_len++] = instr;
}

unsigned code_add_const(code_object *code, unsigned val)
{
    if (!code)
        lisp_panic("code_add_const: null code object");
    code->verified = false;
    // Check if constant already exists
    for (unsigned i = 0; i < code->const_len; i++) {
        if (code->constants[i] == val)
            return i;
    }
    if (code->const_len >= code->const_cap) {
        unsigned new_cap =
            checked_grow_capacity(code->const_cap, sizeof(unsigned),
                                  "code_add_const: capacity overflow");
        unsigned *new_consts =
            checked_realloc_array(code->constants, new_cap, sizeof(unsigned));
        if (!new_consts) {
            lisp_panic("code_add_const: realloc failed");
        }
        code->constants = new_consts;
        code->const_cap = new_cap;
    }
    code->constants[code->const_len] = val;
    return code->const_len++;
}

unsigned code_add_child(code_object *code, code_object *child)
{
    if (!code)
        lisp_panic("code_add_child: null code object");
    code->verified = false;
    if (code->children_len >= code->children_cap) {
        unsigned new_cap =
            checked_grow_capacity(code->children_cap, sizeof(code_object *),
                                  "code_add_child: capacity overflow");
        code_object **new_children = checked_realloc_array(
            code->children, new_cap, sizeof(code_object *));
        if (!new_children) {
            lisp_panic("code_add_child: realloc failed");
        }
        code->children = new_children;
        code->children_cap = new_cap;
    }
    code->children[code->children_len] = child;
    return code->children_len++;
}

unsigned code_current_pos(code_object *code)
{
    return code->code_len;
}

void code_patch(code_object *code, unsigned pos, unsigned val)
{
    if (code)
        code->verified = false;
    if (!code || pos >= code->code_len)
        lisp_panic("code_patch: position out of bounds");
    code->code[pos] = val;
}

// ============================================================================
// GC Integration
// ============================================================================

static void gc_collect_code_inner(code_object *code)
{
    if (!code || !code_object_is_registered(code) ||
        !code_arrays_well_formed(code) || code->gc_updating)
        return;

    code->gc_updating = true;

    // Collect constants
    for (unsigned i = 0; i < code->const_len; i++) {
        code->constants[i] = collect(code->constants[i]);
    }

    // Recursively collect children
    for (unsigned i = 0; i < code->children_len; i++) {
        gc_collect_code_inner(code->children[i]);
    }
}

unsigned gc_collect_code(code_object *code)
{
    gc_collect_code_inner(code);

    // Clear the temporary traversal marks, including in the unlikely case
    // that an invalid child graph prevented a normal recursive unwind.
    for (code_object *it = code_object_registry; it; it = it->gc_next)
        it->gc_updating = false;
    return 0;
}

// Update all code object constants during GC
// Called from gc() in context.c BEFORE the scan phase
void gc_update_all_code_objects(void)
{
    for (code_object *code = code_object_registry; code; code = code->gc_next) {
        if (!code_arrays_well_formed(code))
            continue;
        // Collect constants - the scan phase will then process their CAR/CDR
        for (unsigned i = 0; i < code->const_len; i++) {
            code->constants[i] = collect(code->constants[i]);
        }
    }
}

void minor_gc_update_all_code_objects(void)
{
    for (code_object *code = code_object_registry; code; code = code->gc_next) {
        if (!code_arrays_well_formed(code))
            continue;
        for (unsigned i = 0; i < code->const_len; i++) {
            code->constants[i] = collect_to_old(code->constants[i]);
        }
    }
}

// Mark a code object and all its children as reachable
static void mark_code_object(code_object *code)
{
    if (!code || !code_object_is_registered(code) ||
        !code_arrays_well_formed(code) || code->gc_marked)
        return;
    code->gc_marked = true;
    // Mark children recursively
    for (unsigned i = 0; i < code->children_len; i++) {
        mark_code_object(code->children[i]);
    }
}

bool code_object_is_registered(const code_object *needle)
{
    // Deleted slots are not objects. A malformed closure pointer equal to
    // the marker must never compare as a successful membership-table hit.
    if (!needle || needle == CODE_SET_TOMBSTONE)
        return false;
    // Only trust the table while it holds every registered object. A miss in
    // an incomplete table is not an answer: it would report a live object as
    // unregistered, and the GC would then sweep something still reachable.
    if (code_set_cap && !code_set_incomplete)
        return code_set[code_set_slot_find(code_set, code_set_cap, needle)] ==
               needle;
    for (code_object *code = code_object_registry; code; code = code->gc_next) {
        if (code == needle)
            return true;
    }
    return false;
}

static void mark_registered_code_object(code_object *code)
{
    if (code_object_is_registered(code))
        mark_code_object(code);
}

static void mark_vm_continuation_code(vm_continuation *cont)
{
    if (!vm_continuation_is_registered(cont))
        return;
    mark_registered_code_object(cont->code);
    if (!cont->frames || cont->fp > VM_MAX_FRAMES_SIZE)
        return;
    for (unsigned i = 0; i < cont->fp; i++) {
        mark_registered_code_object(cont->frames[i].code);
    }
}

// Sweep unreachable code objects after GC
// Call this after the heap GC is complete
void gc_sweep_code_objects(void)
{
    // First, clear all marks (pinned objects stay marked forever)
    for (code_object *code = code_object_registry; code; code = code->gc_next) {
        code->gc_marked = code->gc_pinned;
    }

    // Walk the heap and mark code objects referenced by closures
    // Scan old generation: [mmin, hptr)
    for (unsigned i = ctx.mmin; i < ctx.hptr; i++) {
        if (CELL_TYPE(i) == BT_CLOSURE) {
            code_object *code = (code_object *)CELL_PTR(i);
            mark_registered_code_object(code);
        } else if (is_vm_continuation_object(i)) {
            mark_vm_continuation_code((vm_continuation *)CELL_PTR(i));
        }
    }
    // Scan nursery if generational GC is enabled: [nursery_start, nursery_ptr)
    if (ctx.card_table) {
        for (unsigned i = ctx.nursery_start; i < ctx.nursery_ptr; i++) {
            if (CELL_TYPE(i) == BT_CLOSURE) {
                code_object *code = (code_object *)CELL_PTR(i);
                mark_registered_code_object(code);
            } else if (is_vm_continuation_object(i)) {
                mark_vm_continuation_code((vm_continuation *)CELL_PTR(i));
            }
        }
    }

    // Sweep: remove unreachable code objects from registry
    code_object **prev = &code_object_registry;
    while (*prev) {
        code_object *code = *prev;
        if (!code->gc_marked) {
            // Unlink from registry
            *prev = code->gc_next;
            // and from the membership set, or its address stays in there
            // after the free. malloc reuses addresses, so the next code
            // object allocated there would look already-registered, never be
            // added to the registry, and never be traced by the GC.
            code_set_remove(code);
            // Free the code object (but not children - they're in registry too)
            code_destroy_shallow(code);
        } else {
            prev = &code->gc_next;
        }
    }
}