mem.c

#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include "mem.h"
#include "vm.h"
#include "prim.h"
#include "int.na.h"
#include "reaper.na.h"
#include "symbol.h"
#include "config.h"

#define HEAP_SIZE (2 * 1024 * 1024)

int gc_in_progress = 0, fin_in_progress = 0, become_keep_b = 0;

struct fz_head_struct {
    size_t desc;
    datum mtab;
    datum object;
    datum cdr;
    datum state;
};

struct fz_head_struct fz_head = {
    make_desc(DATUM_FORMAT_FZ, 3),
    reaper_mtab,
    nil, /* object */
    nil, /* cdr */
    nil, /* state */
};

static datum perm_base, perm_top, perm_ptr;
static datum busy_base;
#define busy_ptr (regs[R_FREE])
datum busy_top;
static datum to_base, to_top, to_ptr;

static datum trap_pc, trap_pcb;
static int trap_pc_done, trap_pcb_done;

static datum become_a = nil, become_b = nil;
static datum fz_list = (datum) &fz_head.object;

void
init_mem(void)
{
    perm_base = malloc(sizeof(datum) * HEAP_SIZE);
    if (!perm_base) die("init_mem -- out of memory");
    perm_ptr = perm_base;
    perm_top = perm_base + HEAP_SIZE;

    busy_base = malloc(sizeof(datum) * HEAP_SIZE);
    if (!busy_base) die("init_mem -- out of memory");
    busy_ptr = busy_base;
    busy_top = busy_base + HEAP_SIZE;
}

static inline char
datum_desc_format(size_t desc)
{
    return desc & 0xf;
}

static inline size_t
datum_desc_len(size_t desc)
{
    return desc >> 4;
}

#if GC_DEBUG
static const char *datum_types[] = {
    "DATUM_FORMAT_RECORD",
    "DATUM_FORMAT_BROKEN_HEART",
    "DATUM_FORMAT_BACKPTR",
    "DATUM_FORMAT_EMB_OPAQUE",
    "<unused 9>",
    "<unused 11>",
    "DATUM_FORMAT_FZ",
    "DATUM_FORMAT_OPAQUE",
};

static void
prdesc(const char *msg, size_t desc)
{
    if (desc &1) {
        int type = datum_desc_format(desc);
        prfmt(1, "%s %s (%d) len %u\n",
                msg, datum_types[type >> 1], type, datum_desc_len(desc));
    } else {
        prfmt(1, "%s <not a chunk 0x%x>\n", msg, desc);
    }
}
#endif

static inline void
relocate(datum refloc)
{
    datum p, *i, *j;
    size_t len;

    p =  *((datum *) refloc);

    /* don't try to relocate an unboxed int */
    if (((size_t) p) & 1) return;

    if (p < busy_base) return;
    if (p >= busy_top) return;

    --p; /* make p point at the mtab or descriptor */

    for (;;) {
        len = datum_desc_len(*p);
        switch (datum_desc_format(*p)) {
            case DATUM_FORMAT_BACKPTR:
                p -= len;
                continue;

            case DATUM_FORMAT_OPAQUE:
                len = 1 + len / 4;

                if (!trap_pc_done && trap_pc >= p && trap_pc < p + len) {
                    trap_pc_done = 1;
                    trap_pc += to_ptr - p;
                }

                if (!trap_pcb_done && trap_pcb >= p && trap_pcb < p + len) {
                    trap_pcb_done = 1;
                    trap_pcb += to_ptr - p;
                }

                /* fall through */
            case DATUM_FORMAT_RECORD:
            case DATUM_FORMAT_FZ:
#if GC_DEBUG
                prdesc("Relocating", *p);
                prfmt(1, "at %p\n", p);
#endif
                i = (datum *) p;
                j = (datum *) to_ptr;

                /*
                while (j + len >= to_ptr) {
                    to_lim = gmore();
                }
                */

                *j++ = *i++; /* copy the descriptor */
                *j++ = *i++; /* copy the method table pointer */
                while (len--) *j++ = *i++; /* copy the body */

                ((datum *) p)[1] = 2 + (datum) to_ptr;
                to_ptr = (datum) j;
#if GC_DEBUG
                prfmt(1, "Relocated\n");
#endif

                *p = DATUM_FORMAT_BROKEN_HEART;

                /* fall through */
            case DATUM_FORMAT_BROKEN_HEART:
                *refloc += p[1] - ((size_t) (p + 2));
                return;

            case DATUM_FORMAT_EMB_OPAQUE:
            default:
                p--;
                continue;
        }
    }
}

static datum saved_stack = 0, saved_x1 = 0, saved_x2 = 0,
             saved_regs[REG_COUNT] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};

static void
save_regs(datum x1, datum x2)
{
    int i;

    saved_stack = stack;
    for (i = 0; i < REG_COUNT; i++) {
        if (i == R_FREE) continue; /* this register doesn't hold a datum */
        saved_regs[i] = regs[i];
    }
    saved_x1 = x1;
    saved_x2 = x2;
}

static void
restore_regs(datum *x1, datum *x2)
{
    int i;

    stack = saved_stack;
    saved_stack = 0;
    for (i = 0; i < REG_COUNT; i++) {
        if (i == R_FREE) continue; /* this register doesn't hold a datum */
        regs[i] = saved_regs[i];
        saved_regs[i] = 0;
    }
    *x1 = saved_x1;
    *x2 = saved_x2;
}

static void
gc(datum *x1, datum *x2)
{
    int i, live = 0;
    int scanned_finalizers = 0;
    datum np, fzp;
    datum old_become_a, old_become_b;

    if (gc_in_progress) die("ran out of memory during GC");
    gc_in_progress = 1;

#if GC_DEBUG
    prfmt(1, "Start GC\n");
#endif

    trap_pc = regs[R_PC];
    trap_pc_done = !(trap_pc >= busy_base && trap_pc < busy_top);

    trap_pcb = saved_regs[R_PC];
    trap_pcb_done = !(trap_pcb >= busy_base && trap_pcb < busy_top);

    to_base = malloc(sizeof(datum) * HEAP_SIZE);
    if (!to_base) die("gc -- out of memory");
    to_ptr = to_base;
    to_top = to_base + HEAP_SIZE;

#if GC_DEBUG
    prfmt(1, "to_base is %p\n", to_base);
#endif

    if (become_a && become_b) {
        old_become_a = become_a;
        old_become_b = become_b;
        relocate((datum) &become_a);
        relocate((datum) &become_b);
        if (old_become_a != become_a) {
            ((datum *) old_become_a)[-1] = become_b;
        }
        if (old_become_b != become_b && !become_keep_b) {
            ((datum *) old_become_b)[-1] = become_a;
        }
    }

    relocate((datum) &stack);
    relocate((datum) &genv);
    relocate((datum) &symbols);
    relocate((datum) (fz_list + 1));
    relocate((datum) x1);
    relocate((datum) x2);
    for (i = 0; i < REG_COUNT; ++i) {
        if (i == R_FREE) continue; /* this register doesn't hold a datum */
        if (i == R_PC) continue; /* this register doesn't hold a datum */
        relocate((datum) &regs[i]);
    }

    relocate((datum) &saved_stack);
    for (i = 0; i < REG_COUNT; ++i) {
        if (i == R_FREE) continue; /* this register doesn't hold a datum */
        if (i == R_PC) continue; /* this register doesn't hold a datum */
        relocate((datum) saved_regs + i);
    }
    relocate((datum) &saved_x1);
    relocate((datum) &saved_x2);

    np = to_base;
    while (np < to_ptr) {
        while (np < to_ptr) {
            ++live;
            datum p = np + 2;
            size_t descr = *np, len = datum_desc_len(descr);
            relocate(np + 1); /* relocate the method table pointer */
            switch (datum_desc_format(descr)) {
                case DATUM_FORMAT_OPAQUE:
                    np += 3 + len / 4;
                    break;
                case DATUM_FORMAT_FZ:
                    np += len + 2;
                    //relocate(p);
                    relocate(p + 1);
                    break;
                case DATUM_FORMAT_RECORD:
                default:
#if GC_DEBUG
                    prdesc("scanning", descr);
#endif
                    np += len + 2;
                    while (p < np) relocate(p++);
            }
        }

        if (!scanned_finalizers) {
            /* Now process the finalizer list. For each entry:
             *  - if the object died, set fzp's state to 'dead
             *  - relocate the object
             */
            for (fzp = fz_list; fzp != nil; fzp = (datum) fzp[1]) {
                datum p = (datum) fzp[0];
                if (datum_desc_format(p[-2]) != DATUM_FORMAT_BROKEN_HEART) {
                    if (fzp[2] == (size_t) live_sym) fzp[2] = (size_t) dead_sym;
                }
                relocate(fzp);
            }

            scanned_finalizers = 1;
        }
    }

    free(busy_base);
    busy_base = to_base;
    busy_ptr = to_ptr;
    busy_top = to_top;
    if (to_ptr >= to_top) die("gc -- no progress");

    regs[R_PC] = trap_pc;
    saved_regs[R_PC] = trap_pcb;

#if GC_DEBUG
    prfmt(1, "Finish GC\n");
#endif

    gc_in_progress = 0;
    become_a = become_b = nil;

    /* Call x.finalize for each dead x. */
    if (!fin_in_progress) {
        fin_in_progress = 1;
        save_regs(*x1, *x2);
        call(fz_list, reap0_sym, nil);
        restore_regs(x1, x2);
        fin_in_progress = 0;
    }
}

void
fault()
{
    gc(regs + R_NIL, regs + R_NIL);
}

static datum
dalloc(size_t **ptr, size_t **top,
       unsigned char type, uint len, datum mtab, datum x, datum y)
{
    datum p;
    size_t delta = len + 2;

    if (type == DATUM_FORMAT_OPAQUE) {
        delta = 3 + len / 4;
    }

    if ((*ptr + delta) >= *top) gc(&x, &y);
    if ((*ptr + delta) >= *top) die("dalloc -- OOM after gc");
    p = *ptr;
    *p = make_desc(type, len);
    p[1] = (size_t) mtab;
    if (delta > 2) p[2] = (size_t) x;
    if (delta > 3) p[3] = (size_t) y;
    *ptr += delta;
#if GC_DEBUG
    //prdesc("Allocated", *p);
#endif
    return p + 2;
}

size_t
datum_size(datum d)
{
    if (((size_t) d) & 1) return 4;
    while (!(1 & *--d));
    return datum_desc_len(*d);
}

int
opaquep(datum d)
{
    if (((size_t) d) & 1) return 1;
    while (!(1 & *--d));
    return datum_desc_format(*d) == DATUM_FORMAT_OPAQUE;
}

int
broken_heartp(datum x)
{
    if (((size_t) x) & 1) return 1;
    while (!(1 & *--x));
    return datum_desc_format(*x) == DATUM_FORMAT_BROKEN_HEART;
}

datum
datum_mtab(datum d)
{
    if (intp(d)) return int_mtab;
    return (datum) d[-1];
}

void
become(datum *a, datum *b, int keep_b)
{
    become_a = *a;
    become_b = *b;
    become_keep_b = keep_b;
    gc(a, b);
}

/* Note: *x must be the only pointer to x */
void
install_fz(datum *x)
{
    datum fz;

    if (intp(*x)) return;

    fz = dalloc(&busy_ptr,  &busy_top, DATUM_FORMAT_FZ, 3,
            reaper_mtab, (datum) *x, (datum) fz_list[1]);
    fz[2] = (size_t) live_sym;
    fz_list[1] = (size_t) fz;
}

datum
first_reaper()
{
    return fz_list;
}

datum
make_opaque(size_t size, datum mtab)
{
    datum x;
    x = dalloc(&busy_ptr,  &busy_top,
               DATUM_FORMAT_OPAQUE, size, mtab, nil, nil);
    return memset(x, 0, (1 + (size / 4)) * 4);
}

datum
make_record(size_t len, datum mtab, datum a, datum b)
{
    return dalloc(&busy_ptr,  &busy_top,
                  DATUM_FORMAT_RECORD, len, mtab, a, b);
}

datum
make_opaque_permanent(size_t size, datum mtab)
{
    datum x;
    x = dalloc(&perm_ptr, &perm_top,
               DATUM_FORMAT_OPAQUE, size, mtab, nil, nil);
    return memset(x, 0, (1 + (size / 4)) * 4);
}

datum
make_record_permanent(size_t len, datum mtab, datum a, datum b)
{
    return dalloc(&perm_ptr, &perm_top,
                  DATUM_FORMAT_RECORD, len, mtab, a, b);
}