/*
** vim: ts=4 sw=4 expandtab
*/
/*
** Copyright (C) 2009 Ralph Becket <ralphbecket@gmail.com>
** Copyright (C) 2010 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/

/*
** hgc.c - A history-based conservative garbage collector.
**
** TODO: support collection of mutables.
** TODO: explore incremental collection.
** 
** This collector assumes that large and/or mutable heap cells are rare and
** that otherwise all heap cells contain pointers only to less recently
** allocated cells (i.e., a cell allocated at time t will never contain a
** pointer to a cell allocated at time t' > t).  This assumption is
** valid for many declarative programming languages.
** 
** Cells are allocated in 4 Kbyte "pages" (allocated on 4 KByte
** boundaries).  Cells are powers of two in size and are allocated on the
** corresponding address boundaries.  Each page contains cells of the same
** size "payload" (i.e., the user accessible portion of the cell).  The
** first cell in each page is reserved for metadata, specifically the
** payload size and bit mask used to convert a pointer into the page to a
** pointer to the corresponding cell in the page.
** 
** Each cell contains an extra "next" pointer, in addition to the cell
** payload.  This pointer is used to link the cell on to either the
** appropriate free list (there is one free list for each payload size) or
** the allocation chain.  The least significant bit of the "next" pointer
** is used to mark cells by the mark/sweep garbage collector.
** 
** The allocation chain is a singly linked list of cells that have been
** allocated.  The successors of each cell on the allocation list are those
** cells which were allocated before the cell in question.
** 
** Garbage collection proceeds as follows:
** (1) mark all cells referred to from roots (registers, the stack, etc.);
** (2) considering each cell in order on the allocation chain,
** (2a) if the cell is marked then preserve it and mark any cells to which
**     its payload refers;
** (2b) if the cell is not marked then sweep it on to the appropriate free
**     list.
** 
** In this way marking and sweeping occur in a single pass without the need
** for a mark stack.
** 
** Special handling is required for cells that contain mutable data (i.e.,
** which may contain pointers to more recently allocated cells) and for
** "big" cells (i.e., those for which the big-bag-o-pages approach doesn't
** scale).
** 
** NOTES
**
** - "Ordinary" cells (up to a set size) are referred to as "small cells".
** Other cells are referred to as "big cells".  Big cells are assumed to be
** rare and are allocated using a different structure (see hgc_big.c).
** 
** - Empirically, bit-masking is nearly ten times faster than using division
** and modulo arithmetic, which makes a modest amount of memory wastage
** acceptable for performance.  This is why cells are allocated on power-
** of-two address boundaries.
**
** - We could consider using a spare tag bit to identify cells that contain
** only non-pointer data (and thereby avoid marking through them).  This
** could be useful for allocating strings and arrays of numbers.
*/

#include "mercury_imp.h"

#ifdef MR_HGC

/*
** Default values that can be overridden by setting the appropriate
** environment variable (e.g., set HGC_X or get default_HGC_X).
** Sizes are in megabytes, except for the growth variables which are
** per centages.
*/

/* Amount of memory (in megabytes) to reserve for the entire heap. */
#define default_HGC_HEAP_SIZE 256

/* Megabytes consumed before the first GC by the small heap. */
#define default_HGC_INITIAL_SMALL_HEAP_SIZE 1

/* More than this per centage of live data causes the small heap to grow. */
#define default_HGC_GROWTH_THRESHOLD 20

/* The per centage by which the small heap is grown. */
#define default_HGC_GROWTH_FACTOR 50

/* Megabytes consumed before the first GC by the big heap. */
#define default_HGC_INITIAL_BIG_HEAP_SIZE 1

#include <stdio.h>
#include <setjmp.h>
#include <bits/setjmp.h>

#include "mercury_hgc.h"
#include "mercury_expanding_array.h"

#ifdef TRACE_HGC    /* Define this to enable tracing messages. */
#define TRC
#else
#define TRC if (0)
#endif

typedef MR_Integer hgc_int;
typedef MR_Word hgc_word;
typedef hgc_word* hgc_ptr;

#define hgc_num_tag_bits (MR_LOW_TAG_BITS)

#define word_size_bytes (sizeof(hgc_word))
#define words(size_in_bytes) \
    (((size_in_bytes) + word_size_bytes - 1) / word_size_bytes)
#define bytes(size_in_words) \
    ((size_in_words) * word_size_bytes)

/*
** The least significant bit of the cell "next" field is used as a "mark bit"
** to indicate live data during mark/sweep garbage collection.
*/
#define tag_mask (((hgc_int)(1 << hgc_num_tag_bits)) - 1)
#define addr_mask (~tag_mask)
#define tag(p) (((hgc_int)(p)) & tag_mask)
#define untag(p) (hgc_ptr)(((hgc_int)(p)) & addr_mask)
#define set_tag(p) (hgc_ptr)(((hgc_int)(p)) | 0x1)
#define clear_tag(p) (hgc_ptr)(((hgc_int)(p)) & ~0x1)

/*
** A page is a 4 KByte collection of small_cells of the same payload size.
** The first cell on a page is reserved for page meta-data (the bit mask
** used to find the start address of cells in the page and the payload
** size of the cells in the page).  Pages are allocated upwards from the
** bottom of the heap.
*/
#define page_size_in_bytes (1 << 12)
#define page_size words(page_size_in_bytes)
#define page_mask (~(hgc_int)(page_size_in_bytes - 1))
#define page(p) (hgc_ptr)((hgc_int)(p) & page_mask)
#define page_small_cell_mask(pg) ((pg) + 0)
#define page_payload_size(pg) (hgc_int *)((pg) + 1)
#define page_small_cell(pg, p) \
    (hgc_ptr)((hgc_int)(p) & *page_small_cell_mask(pg))

/*
** Small cells.
** A small_cell consists of a "next" pointer (either in the allocation list
** or the corresponding free list), the payload data, and padding to round
** the cell size up to a power of two.  ALWAYS remember to untag the value
** obtained from dereferencing small_cell_next.
*/
#define small_cell_next(cl) (hgc_ptr *)((cl) + 0)
#define get_small_cell_next(cl) untag(*small_cell_next(cl))
#define set_small_cell_next(cl, p) *small_cell_next(cl) = (p)
#define small_cell_payload(cl) ((cl) + 1)
#define max_small_payload 32            /* Sizes 0..max_small_payload. */

/*
** Big cells.
** The prev field is the backwards link for a big_cell on a free list.
** The is_free field is 0 iff the cell is not on a free list.
** A size_index field of k means the cell occupies 1<<k words.
** The big_cell with the lowest address is found at big_bot. ALWAYS remember
** to untag the value obtained form dereferencing big_cell_next.
*/
#define big_cell_next(cl) (hgc_ptr *)((cl) + 0)
#define get_big_cell_next(cl) untag(*big_cell_next(cl))
#define set_big_cell_next(cl, p) *big_cell_next(cl) = (p)
#define big_cell_prev(cl) (hgc_ptr *)((cl) + 1)
#define get_big_cell_prev(cl) *big_cell_prev(cl)
#define set_big_cell_prev(cl, p) *big_cell_prev(cl) = (p)
#define big_cell_is_free(cl) (hgc_int *)((cl) + 1)
#define big_cell_size_index(cl) (hgc_int *)((cl) + 2)
#define big_cell_payload_size(cl) (hgc_int *)((cl) + 3)
#define big_cell_payload(cl) ((cl) + 4)
#define big_cell_min_size(payload_size) ((payload_size) + 4)
#define big_cell_buddy(cl) \
    (big_bot + (((cl) - big_bot) ^ (1 << *big_cell_size_index(cl))))
#define min_big_cell_size_index 5
#define max_big_cell_size_index 64

static hgc_int hgc_initialised = 0;     /* 1 if hgc_init() has been called. */
static hgc_ptr heap_bot = NULL;         /* Start of heap memory. */
static hgc_ptr heap_top;                /* One past heap end. */
static hgc_ptr small_bot = NULL;        /* The first initialised page. */
static hgc_ptr small_top;               /* One past last initialised page. */
static hgc_ptr small_high_water;        /* Used to control heap expansion. */
static hgc_int growth_threshold = 20;   /* Grow small heap if more than
                                        ** this percent of memory is live.
                                        */
static hgc_int growth_factor = 50;      /* Percent growth for
                                        ** small_high_water
                                        */
static hgc_ptr small_cell_free_list[max_small_payload + 1];
                                        /* Array of small_cell free lists. */
static hgc_ptr big_bot = NULL;          /* The start of the big_cell heap. */
static hgc_ptr big_top;                 /* One past the end. */
static hgc_int big_size_index;          /* big_top =
                                        **      big_bot + 1 << big_size_index
                                        */
static hgc_ptr big_low_water;           /* Used to control heap expansion. */
static hgc_ptr alloc_list = NULL;       /* List of allocated cells. */
static hgc_ptr big_cell_free_list[max_big_cell_size_index + 1];
                                        /* Array of big_cell free lists. */
static hgc_ptr *stack_bot = NULL;       /* Base of the C stack. */

/*
** The roots structure is used to hold fixed ranges of addresses that
** may contain pointers to cells.
*/
struct roots_range {
    hgc_ptr *roots_bot;                 /* Start of range. */
    hgc_ptr *roots_top;                 /* One past end of range. */
};

/*
** Define the roots_array expanding array type and its operations.
*/
MR_DEFINE_EXPANDING_ARRAY(roots_array, struct roots_range, 256);

static roots_array *roots = NULL;       /* The roots ranges. */

/*
** Define the mutables_array expanding array type and its operations.
*/
MR_DEFINE_EXPANDING_ARRAY(mutables_array, hgc_ptr, 256);

static mutables_array *mutables = NULL; /* The mutables array. */

/*
** Define the uncollectables_array expanding array type and its operations.
*/
MR_DEFINE_EXPANDING_ARRAY(uncollectables_array, hgc_ptr, 256);

static uncollectables_array *uncollectables = NULL; 

/*
** ===========================================================================
** Small heap management.
** ===========================================================================
*/

/*
** Set the mark bit on a small_cell (the mark bit lives in the
** small_cell_next field).
*/
static void
mark_small_cell(hgc_ptr cl)
{
    set_small_cell_next(cl, set_tag(get_small_cell_next(cl)));
}

/*
** Return non-zero iff the mark bit is set on this small_cell.
*/
static hgc_int
small_cell_is_marked(hgc_ptr cl)
{
    return tag(*small_cell_next(cl));
}

/*
** Find the small_cell referenced by a pointer.
** Returns 0 iff the pointer points outside the small heap.
*/
static int
find_small_cell(hgc_ptr p, hgc_ptr *cl_ref, hgc_ptr *payload_ref,
        hgc_int *payload_size_ref)
{
    if (small_bot <= p && p < small_top) {
        hgc_ptr pg = page(p);
        *cl_ref = page_small_cell(pg, p);
        *payload_size_ref = *page_payload_size(pg);
        *payload_ref = small_cell_payload(*cl_ref);
        return 1;
    } else {
        return 0;
    }
}

/*
** Initialise a new page and add its small_cells to the given
** small_cell_free_list.
*/
static void
init_new_page(hgc_int payload_size)
{
    hgc_ptr pg;
    hgc_int pg_cell_size;
    hgc_ptr cl;

    TRC if (!hgc_initialised) {
        fprintf(stderr, "hgc: hgc_init() has not been called.\n");
        exit(1);
    }

    pg = small_top;
    small_top += page_size;
    if (small_top > big_low_water) {
        fprintf(stderr, "hgc: init_new_page: out of memory.\n");
        exit(1);
    }

    /*
    ** Each small_cell has to be at least one word larger than its payload to
    ** include the small_cell_next 'history' pointer.  Cell sizes are always
    ** a power of 2.
    */
    for (pg_cell_size = 2; pg_cell_size <= payload_size; pg_cell_size <<= 1) {}
    *page_payload_size(pg) = payload_size;
    /*
    ** Cells are allocated at addresses that are multiples of the small_cell
    ** size.
    */
    *page_small_cell_mask(pg) = ~((pg_cell_size * sizeof(hgc_word)) - 1);

    /*
    ** Add the small_cells in this page to the appropriate free list
    ** (recall that the first cell in a page is reserved for page metadata).
    */
    for (cl = pg + pg_cell_size; cl < small_top; cl += pg_cell_size) {
        set_small_cell_next(cl, small_cell_free_list[payload_size]);
        small_cell_free_list[payload_size] = cl;
    }
}

/*
** Allocate a new small_cell from a free list (the pointer returned is to
** the small_cell, not its payload).
*/
static hgc_ptr
alloc_small_cell(hgc_int payload_size)
{
    hgc_ptr cl = small_cell_free_list[payload_size];

    if (cl != NULL) {

        small_cell_free_list[payload_size] = get_small_cell_next(cl);
        set_small_cell_next(cl, alloc_list);
        alloc_list = cl;
        return cl;

    }

    /*
    ** There are no free cells of this size.  Allocate a new page if possible.
    */
    if (small_top + page_size <= small_high_water) {
        init_new_page(payload_size);
        return alloc_small_cell(payload_size);
    }

    /*
    ** We can't allocate a new page, try garbage collecting.
    */
    MR_hgc_gc();
    if (small_cell_free_list[payload_size] != NULL) {
        return alloc_small_cell(payload_size);
    }

    /*
    ** Try growing small_high_water.
    */
    small_high_water =
        small_bot + ((100 + growth_factor) * (small_top - small_bot)) / 100;
    if (small_high_water <= big_low_water) {
        return alloc_small_cell(payload_size);
    }

    /*
    ** Nope, we're out of memory.
    */
    fprintf(stderr, "hgc: alloc_small_cell: out of memory.\n");
    exit(1);
}

/*
** ===========================================================================
** Big heap management.
** ===========================================================================
*/

/*
** "Big" cells don't work well in the BIBOP approach used for "small" cells
** and indeed some big cells won't even fit inside a small_cell page.  Instead
** we use a buddy style memory allocator.
**
** Each big_cell is a power of two words in size.  A big_cell can be split into
** two smaller, equally sized, "buddy" big_cells.  If both buddies become free,
** they are merged into a single cell of the next size up.  A free list exists
** for each size of big_cell.  Allocations are made to the smallest sized
** big_cell that can accommodate the payload; this may mean first splitting up
** a larger big_cell if one of the right size is unavailable.
**
** To support O(1) removal of a buddy from its free list during free cell
** merging, each free list is doubly linked.  We re-use the "prev" field
** to indicate whether a big_cell is allocated or not (it is NULL if it
** is allocated, non-NULL otherwise).
*/

/*
** Set the mark bit on a big_cell (the mark bit lives in the
** big_cell_next field).
*/
static void
mark_big_cell(hgc_ptr cl)
{
    set_big_cell_next(cl, set_tag(get_big_cell_next(cl)));
}

/*
** Return non-zero iff the mark bit is set on this big_cell.
*/
static hgc_int
big_cell_is_marked(hgc_ptr cl)
{
    return tag(*big_cell_next(cl));
}

/*
** Print out a representation of the big cell heap for debugging.
*/
static void
print_big_cells(void)
{
    hgc_ptr cl;
    hgc_int ix;

    for (cl = big_bot; cl < big_top; cl += 1 << ix) {
        int i;
        ix = *big_cell_size_index(cl);
        for (i = big_size_index - ix; i > 0; i--) {
            printf("  ");
        }
        printf("[ %l ] %p ", ix, cl);
        if (*big_cell_is_free(cl)) {
            printf("free\n");
        } else {
            printf("allocated %l\n", *big_cell_payload_size(cl));
        }
    }
}

static void
print_big_cell_free_list(void)
{
    hgc_int i;
    hgc_ptr cl;

    for (i = 0; i <= max_big_cell_size_index; i++) {
        if (big_cell_free_list[i] != NULL) {
            printf("free %2d", i);
            for (
                cl = big_cell_free_list[i];
                cl != NULL;
                cl = get_big_cell_next(cl)
            ) {
                printf(" %p", cl);
                /* Do some sanity checking. */
                if (! *big_cell_is_free(cl)) {
                    printf(" is not marked as free!\n");
                    exit(1);
                }
                if (*big_cell_size_index(cl) != i) {
                    printf(" has the wrong size index!\n");
                    exit(1);
                }
            }
            printf("\n");
        }
    }
}

static void
print_big_heap(void)
{
    printf("big_top = %p\n", big_top);
    printf("big_bot = %p\n", big_bot);
    printf("big heap is %l words\n", big_top - big_bot);
    printf("big_size_index = %l\n", big_size_index);
    print_big_cells();
    print_big_cell_free_list();
}

/*
** Check the integrity of the big heap.
*/
static void
check_big_heap(void)
{
    hgc_ptr cl;
    hgc_ptr prev_cl;
    hgc_int ix;
    /*
    ** Mark every free cell with a 0xDEADBEEF marker in its first
    ** payload slot.
    */
    for (cl = big_bot; cl < big_top; cl += 1 << *big_cell_size_index(cl)) {
        if (*big_cell_is_free(cl)) {
            *big_cell_payload(cl) = 0xDEADBEEF;
        }
    }
    /*
    ** Check the sizes and links on the free lists.
    */
    for (ix = 0; ix <= max_big_cell_size_index; ix++) {
        prev_cl = (hgc_ptr)(1);
        for (
            cl = big_cell_free_list[ix];
            cl != NULL;
            cl = get_big_cell_next(cl)
        ) {
            if (*big_cell_size_index(cl) != ix) {
                printf("hgc: check_big_heap: %p has size index %l, "
                        "but should have %l\n", cl,
                        *big_cell_size_index(cl), ix);
                print_big_heap();
                exit(1);
            }
            if (get_big_cell_prev(cl) != prev_cl) {
                printf("hgc: check_big_heap: %p has prev pointer %p, "
                        "but should have %p\n", cl,
                        get_big_cell_prev(cl), prev_cl);
                print_big_heap();
                exit(1);
            }
            if (*big_cell_payload(cl) != 0xDEADBEEF) {
                printf("hgc: check_big_heap: %p is free, but does not "
                        "contain 0xDEADBEEF\n", cl);
                print_big_heap();
                exit(1);
            }
            prev_cl = cl;
        }
    }
}

/*
** Find the big_cell referenced by a pointer.
** Returns 0 iff the pointer points outside the big heap or the cell
** referenced is unallocated.
*/
static int
find_big_cell(hgc_ptr p, hgc_ptr *cl_ref, hgc_ptr *payload_ref,
        hgc_int *payload_size_ref)
{
    hgc_ptr cl = big_bot;
    hgc_int ix = big_size_index;
    hgc_int size = 1 << big_size_index;
    if (p < big_bot || big_top <= p) {
        return 0;
    }
    while (1) {
        if (*big_cell_size_index(cl) == ix) {
            /*
            ** We've found the cell.
            */
            if (*big_cell_is_free(cl)) {
                return 0;
            }
            *cl_ref = cl;
            *payload_ref = big_cell_payload(cl);
            *payload_size_ref = *big_cell_payload_size(cl);
            return 1;
        }
        /*
        ** It has to be a subdivision of this cell.
        */
        ix--;
        size /= 2;
        if (cl + size <= p) {
            /*
            ** It's in the upper half.
            */
            cl += size;
        }
    }
}

/*
** Add a big_cell to the appropriate free list (but don't attempt to merge
** with its buddy).
*/
static void
add_big_cell_to_free_list(hgc_ptr cl)
{
    hgc_int ix = *big_cell_size_index(cl);
    hgc_ptr next_cl = big_cell_free_list[ix];
    big_cell_free_list[ix] = cl;
        /* We have to mark this cell as free. */
    *big_cell_is_free(cl) = 1;
    set_big_cell_next(cl, next_cl);
    if (next_cl != NULL) {
        set_big_cell_prev(next_cl, cl);
    }
}

/*
** Unlink a big_cell from its free list.
*/
static void
unlink_big_cell_from_free_list(hgc_ptr cl)
{
    hgc_ptr next_cl = get_big_cell_next(cl);
    hgc_ptr prev_cl = get_big_cell_prev(cl);
    hgc_int ix = *big_cell_size_index(cl);

    if (big_cell_free_list[ix] == cl) {
        big_cell_free_list[ix] = next_cl;
    } else {
        set_big_cell_next(prev_cl, next_cl);
    }
    if (next_cl != NULL) {
        set_big_cell_prev(next_cl, prev_cl);
    }
}

/*
** Split an unlinked big_cell in two and add the upper half to the
** appropriate free list.
*/
static void
split_big_cell(hgc_ptr cl)
{
    hgc_int new_ix = *big_cell_size_index(cl) - 1;
    hgc_int new_size = 1 << new_ix;
    hgc_ptr buddy = cl + new_size;
    *big_cell_size_index(cl) = new_ix;
    *big_cell_size_index(buddy) = new_ix;
    add_big_cell_to_free_list(buddy);
}

/*
** Free an unlinked big_cell, making sure we recursively merge it with its
** buddy as long as its buddy is free.
*/
static void
free_big_cell(hgc_ptr cl)
{
    hgc_int ix = *big_cell_size_index(cl);
    hgc_ptr buddy = big_cell_buddy(cl);
    while (
        ix < big_size_index &&
        *big_cell_size_index(buddy) == ix &&
        *big_cell_is_free(buddy)
    ) {
        unlink_big_cell_from_free_list(buddy);
        if (buddy < cl) {
            cl = buddy;
        }
        ix++;
        *big_cell_size_index(cl) = ix;
        buddy = big_cell_buddy(cl);
    }
    add_big_cell_to_free_list(cl);
}

/*
** Allocate a free big_cell of the right size.
*/
static hgc_ptr
alloc_big_cell(hgc_int payload_size)
{
    hgc_int min_cell_size = big_cell_min_size(payload_size);
    hgc_int ix;
    hgc_int size;

    /*
    ** Find the smallest sufficiently large free big_cell.
    */
    for (
        ix = min_big_cell_size_index, size = 1 << ix;
        ix <= big_size_index;
        ix++, size = 1 << ix
    ) {
        if (size >= min_cell_size && big_cell_free_list[ix] != NULL) {
            /*
            ** Found one.  Now we may need to split it down to size.
            */
            hgc_ptr cl = big_cell_free_list[ix];
            unlink_big_cell_from_free_list(cl);
            while (size / 2 >= min_cell_size) {
                split_big_cell(cl);
                size /= 2;
            }
            /*
            ** Add it to the alloc_list and return the big_cell.
            */
            *big_cell_payload_size(cl) = payload_size;
            *big_cell_is_free(cl) = 0;
            set_big_cell_next(cl, alloc_list);
            alloc_list = cl;

            return cl;
        }
    }

    /*
    ** We couldn't find a big enough cell.  We can either grow the big heap
    ** or try garbage collecting.
    */
    size = big_top - big_bot;
    if (big_bot - size >= big_low_water) {
        /*
        ** We can grow the big heap.
        */
        big_bot -= size;
        *big_cell_size_index(big_bot) = big_size_index;
        big_size_index++;
        free_big_cell(big_bot);
        return alloc_big_cell(payload_size);
    }

    /*
    ** We can't grow the big heap right now; try garbage collecting and
    ** seeing what happens.
    */
    MR_hgc_gc();
    for (ix = big_size_index; 0 <= ix && min_cell_size <= 1 << ix; ix --) {
        if (big_cell_free_list[ix] != NULL) {
            return alloc_big_cell(payload_size);
        }
    }

    /*
    ** Try growing big_low_water.
    */
    size = big_top - big_bot;
    if (big_low_water - size >= small_high_water) {
        big_low_water -= size;
        return alloc_big_cell(payload_size);
    }
    
    /*
    ** Nope, we're out of memory.
    */
    fprintf(stderr, "hgc: alloc_big_cell: out of memory.\n");
    exit(1);
}

/*
** ===========================================================================
** Top-level garbage collection code.
** ===========================================================================
*/

/*
** Find a cell (small or big).  Returns 0 iff the pointer does not point to
** a valid cell.
*/
static int
find_cell(hgc_ptr p, hgc_ptr *cl_ref, hgc_ptr *payload_ref,
        hgc_int *payload_size_ref)
{
    return  find_small_cell(p, cl_ref, payload_ref, payload_size_ref) ||
            find_big_cell(p, cl_ref, payload_ref, payload_size_ref);
}

/*
** If p points to a cell in the heap then mark that cell.
*/
static void
mark_ptr_target(hgc_ptr p)
{
    hgc_ptr cl;
    hgc_ptr payload;
    hgc_int payload_size;
    p = untag(p);
    if (
            find_small_cell(p, &cl, &payload, &payload_size) &&
            payload <= p && p < payload + payload_size
    ) {
        mark_small_cell(cl);
        return;
    }
    if (
            find_big_cell(p, &cl, &payload, &payload_size) &&
            payload <= p && p < payload + payload_size
    ) {
        mark_big_cell(cl);
        return;
    }
}

/*
** Perform a single-pass mark and sweep of the alloc_list.
** If we fail to collect enough memory, allow extra pages by
** extending small_high_water.
*/
static void
mark_and_sweep_alloc_list(void)
{
    hgc_ptr pg;
    hgc_ptr cl;
    hgc_ptr next_cl;
    hgc_ptr payload;
    hgc_ptr p;
    hgc_ptr *alloc_list_tail;
    hgc_int payload_size;
    hgc_int small_live_mem = 0;
    hgc_int small_dead_mem = 0;
    hgc_int big_live_mem = 0;
    hgc_int big_dead_mem = 0;

    TRC printf("hgc: mark_and_sweep_alloc_list()\n");

    TRC {
        int n;
        for (
            n = 0, cl = alloc_list;
            cl != NULL;
            n++, cl = (cl < small_top) ? get_small_cell_next(cl)
                                       : get_big_cell_next(cl)
        ) {}
        printf("hgc: mark_and_sweep_alloc_list: %l cells on alloc_list\n", n);
    }

    cl = alloc_list;
    alloc_list = NULL;
    alloc_list_tail = &alloc_list;
    while (cl != NULL) {

        if (cl < small_top) {

            /*
            ** This is a small_cell.
            */

            next_cl = get_small_cell_next(cl);
            pg = page(cl);
            payload_size = *page_payload_size(pg);

            if (small_cell_is_marked(cl)) {

                payload = small_cell_payload(cl);
                for (p = payload; p < payload + payload_size; p++) {
                    mark_ptr_target((hgc_ptr)(*p));
                }
                *alloc_list_tail = cl;
                alloc_list_tail = small_cell_next(cl);
                small_live_mem += payload_size;

            } else {

                set_small_cell_next(cl, small_cell_free_list[payload_size]);
                small_cell_free_list[payload_size] = cl;
                small_dead_mem += payload_size;

            }

        } else {

            /*
            ** This is a big_cell.
            */

            next_cl = get_big_cell_next(cl);
            payload = big_cell_payload(cl);
            payload_size = *big_cell_payload_size(cl);

            if (big_cell_is_marked(cl)) {

                for (p = payload; p < payload + payload_size; p++) {
                    mark_ptr_target((hgc_ptr)(*p));
                }
                *alloc_list_tail = cl;
                alloc_list_tail = big_cell_next(cl);
                big_live_mem += payload_size;

            } else {

                free_big_cell(cl);
                big_dead_mem += payload_size;

            }

        }

        cl = next_cl;
    }
    /*
    ** Important!  We have to terminate the alloc_list properly.
    */
    *alloc_list_tail = NULL;

    TRC {
        check_big_heap();
        print_big_heap();
        printf("hgc: mark_and_sweep_alloc_list: "
                "%l live words in small_cells\n",
                small_live_mem);
        printf("hgc: mark_and_sweep_alloc_list: "
                "%l dead words in small_cells\n",
                small_dead_mem);
        printf("hgc: mark_and_sweep_alloc_list: "
                "%l live words in big_cells\n",
                big_live_mem);
        printf("hgc: mark_and_sweep_alloc_list: "
                "%l dead words in big_cells\n",
                big_dead_mem);
        printf("hgc: mark_and_sweep_alloc_list: small_bot = %p\n",
                small_bot);
        printf("hgc: mark_and_sweep_alloc_list: small_top = %p\n",
                small_top);
        printf("hgc: mark_and_sweep_alloc_list: small_h/w = %p\n",
                small_high_water);
        printf("hgc: mark_and_sweep_alloc_list: big_top   = %p\n",
                big_top);
        printf("hgc: mark_and_sweep_alloc_list: big_bot   = %p\n",
                big_bot);
        printf("hgc: mark_and_sweep_alloc_list: big_l/w   = %p\n",
                big_low_water);
        printf("\n");
    }
}

/*
** Look up an environment variable.  Return a default value if the envvar
** is absent or negative.
*/
static hgc_int
lookup_env_var(const char *name, hgc_int default_value)
{
    char *envvar = getenv(name);
    if (envvar == NULL) {
        return default_value;
    } else {
        hgc_int val = atoi(envvar);
        if (val < 0) {
            return default_value;
        } else {
            return val;
        }
    }
}

/*
** Initialise the heap.
*/
void
MR_hgc_init(void)
{
    hgc_int heap_size;                  /* In words. */
    hgc_int initial_small_heap_size;    /* In words. */
    hgc_int initial_big_heap_size;      /* In words. */
    hgc_int initial_heap_size;          /* In words. */
    hgc_ptr heap_midpoint;
    int i;
    char *envvar;

    /*
    ** Just return if we've already been initialised.
    */
    if (hgc_initialised) {
        return;
    }

    /*
    ** Set stack_bot if it hasn't already been fixed.
    */
    if (stack_bot == NULL) {
        stack_bot = (hgc_ptr *)(&heap_size);
    }

    /*
    ** Check the environment variables.
    */
    heap_size =
        words(lookup_env_var("HGC_HEAP_SIZE",
                    default_HGC_HEAP_SIZE) << 20);

    growth_threshold =
        lookup_env_var("HGC_GROWTH_THRESHOLD",
                default_HGC_GROWTH_THRESHOLD);

    growth_factor =
        lookup_env_var("HGC_GROWTH_FACTOR",
                default_HGC_GROWTH_FACTOR);

    initial_small_heap_size =
        words(lookup_env_var("HGC_INITIAL_SMALL_HEAP_SIZE",
                    default_HGC_INITIAL_SMALL_HEAP_SIZE) << 20);

    initial_big_heap_size =
        words(lookup_env_var("HGC_INITIAL_BIG_HEAP_SIZE",
                    default_HGC_INITIAL_BIG_HEAP_SIZE) << 20);

    initial_heap_size = initial_small_heap_size + initial_big_heap_size;

    /*
    ** Ask for as much memory as malloc will give us, give or take a factor
    ** of two.
    */
    for (
        heap_bot = NULL;
        heap_bot == NULL && heap_size >= initial_heap_size;
        heap_size /= 2
    ) {
        heap_bot = (hgc_ptr)malloc(heap_size * sizeof(hgc_word));
    }
    if (heap_bot == NULL) {
        fprintf(stderr, "hgc: failed to malloc heap.\n");
        exit(1);
    }
    TRC printf("hgc: hgc_init: allocated %l MByte heap.\n",
        (heap_size * sizeof(hgc_word)) >> 20);

    /*
    ** Set up the small heap (this grows upwards).
    */
    heap_top = heap_bot + heap_size;
    heap_midpoint = heap_bot + (heap_size / 2);
    small_bot = page(heap_bot + page_size - 1);
    small_top = small_bot;
    small_high_water = small_bot + initial_small_heap_size;
    for (i = 0; i <= max_small_payload; i++) {
        small_cell_free_list[i] = NULL;
    }

    /*
    ** Set up the big heap (this grows downwards).  We have to create the
    ** initial empty cell and add it to the right free list.
    */
    for (i = 0; i <= max_big_cell_size_index; i++) {
        big_cell_free_list[i] = NULL;
    }
    big_size_index = min_big_cell_size_index;
    if (big_low_water < small_high_water) {
        big_low_water = small_high_water;
    }
    big_top = heap_top;
    big_bot = heap_top - (1 << min_big_cell_size_index);
    *big_cell_size_index(big_bot) = min_big_cell_size_index;
    add_big_cell_to_free_list(big_bot);
    big_low_water = big_top - initial_big_heap_size;

    /*
    ** Set up the roots and mutables arrays.
    */
    roots = init_roots_array();
    mutables = init_mutables_array();
    uncollectables = init_uncollectables_array();

    /*
    ** Report that all is well.
    */
    hgc_initialised = 1;
}

/*
** Add a roots range.
*/
void
MR_hgc_add_roots_range(void *bot, void *top)
{
    struct roots_range rr = {bot, top};
    TRC if (!hgc_initialised) {
        fprintf(stderr, "hgc: hgc_init() has not been called.\n");
        exit(1);
    }
    roots = roots_array_append_item(roots, rr);
}

void
MR_hgc_add_root(void *rt)
{
    MR_hgc_add_roots_range(rt, rt + 1);
}

/*
** Mark any cells referred to on the C stack.
*/
static void
mark_from_C_stack(void)
{
    hgc_ptr *stack_top = (hgc_ptr *)(&stack_top);
    hgc_ptr *bot = (stack_bot < stack_top) ? stack_bot : stack_top;
    hgc_ptr *top = (stack_bot < stack_top) ? stack_top : stack_bot;
    hgc_ptr *p;

    TRC printf("hgc: mark_from_C_stack()\n");

    for (p = bot; p <= top; p++) {
        mark_ptr_target(*p);
    }
}

/*
** Mark any cells referred to in registers.  This is currenty very Linux
** centric.
*/
static void
mark_from_registers(void)
{
    jmp_buf jbuf;
    hgc_ptr *bot;
    hgc_ptr *top;
    hgc_ptr *p;

    TRC printf("hgc: mark_from_registers()\n");

    (void)setjmp(jbuf);                 /* Copy the register file. */
    bot = (hgc_ptr *)(jbuf[0].__jmpbuf);
    top = (hgc_ptr *)(&(jbuf[0].__mask_was_saved));

    TRC printf("hgc: mark_from_registers: %l registers\n", top - bot);

    for (p = bot; p <= top; p++) {
        mark_ptr_target(*p);
    }
}

/*
** Mark any cells referred to in the roots array ranges.
*/
static void
mark_from_roots(void)
{
    int i;

    TRC printf("hgc: mark_from_roots()\n");

    for (i = roots_array_num_occupants(roots) - 1; i >= 0; i--) {
        struct roots_range rr = roots_array_get_item(roots, i);
        hgc_ptr *p;
        for (p = rr.roots_bot; p < rr.roots_top; p++) {
            mark_ptr_target(*p);
        }
    }
}

/*
** Mark a cell and any cells referenced in its payload.
*/
static void
mark_cell_and_referents(hgc_ptr p)
{
    hgc_ptr cl;
    hgc_ptr payload;
    hgc_int payload_size;
    if (find_small_cell(p, &cl, &payload, &payload_size)) {
        mark_small_cell(cl);
        for (p = payload; p < payload + payload_size; p++) {
            mark_ptr_target((hgc_ptr)*p);
        }
        return;
    }
    if (find_big_cell(p, &cl, &payload, &payload_size)) {
        mark_big_cell(cl);
        for (p = payload; p < payload + payload_size; p++) {
            mark_ptr_target((hgc_ptr)*p);
        }
        return;
    }
}

/*
** Mark any uncollectable cells and their referents.
*/
static void
mark_from_uncollectables(void)
{
    int i;
    int n = uncollectables_array_num_occupants(uncollectables);

    TRC printf("hgc: mark_from_uncollectables()\n");

    for (i = 0; i < n; i++) {
        mark_cell_and_referents(
            uncollectables_array_get_item(uncollectables, i)
        );
    }
}

/*
** Mark any cells referred to in the mutables array and any cells
** referred to by those mutables.
*/
static void
mark_from_mutables(void)
{
    int i;
    int n = mutables_array_num_occupants(mutables);

    TRC printf("hgc: mark_from_mutables()\n");

    for (i = 0; i < n; i++) {
        mark_cell_and_referents(
            mutables_array_get_item(mutables, i)
        );
    }
}

/*
** Perform a garbage collection.
*/
void
MR_hgc_gc(void)
{
    TRC if (!hgc_initialised) {
        fprintf(stderr, "hgc: hgc_init() has not been called.\n");
        exit(1);
    }
    TRC printf("hgc: hgc_gc()\n");
    mark_from_roots();
    mark_from_C_stack();
    mark_from_registers();
    mark_from_uncollectables();
    mark_from_mutables();
    mark_and_sweep_alloc_list();
}

/*
** Malloc replacement.
*/
void *
MR_hgc_malloc_immutable(size_t size_bytes)
{
    hgc_int size = words(size_bytes);

    TRC if (!hgc_initialised) {
        fprintf(stderr, "hgc: hgc_init() has not been called.\n");
        exit(1);
    }
    if (size <= max_small_payload) {
        return small_cell_payload(alloc_small_cell(size));
    } else {
        return big_cell_payload(alloc_big_cell(size));
    }
}

/*
** Add a cell to the mutables array.
*/
void
MR_hgc_make_mutable(void *p)
{
    mutables = mutables_array_append_item(mutables, (hgc_ptr) p);
}

/*
** Allocate a mutable cell.
*/
void *
MR_hgc_malloc_mutable(size_t size_bytes)
{
    void *p = MR_hgc_malloc_immutable(size_bytes);
    MR_hgc_make_mutable(p);
    return p;
}

/*
** Make a cell uncollectable (i.e., always live).
*/
void
MR_hgc_make_uncollectable(void *p)
{
    uncollectables = uncollectables_array_append_item(uncollectables, p);
}

/*
** Allocate an uncollectable, mutable cell.
*/
void *
MR_hgc_malloc_uncollectable(size_t size_bytes)
{
    void *p = MR_hgc_malloc_mutable(size_bytes);
    MR_hgc_make_uncollectable(p);
    return p;
}

/*
** Allow the application to change stack_bot.
*/
void
MR_hgc_set_stack_bot(void *p)
{
    stack_bot = (hgc_ptr *)untag((hgc_ptr) p);
}

/*
** If necessary, allocate a new cell of the given size and copy as much of the
** data from the old cell as will fit.  The new cell is mutable if the old cell
** is.  The new cell is uncollectable if the old cell is.
*/
void *
MR_hgc_realloc(void *p, size_t size_bytes)
{
    hgc_int new_payload_size = words(size_bytes);
    hgc_ptr old_cl;
    hgc_ptr old_payload;
    hgc_int old_payload_size;
    if (find_cell(p, &old_cl, &old_payload, &old_payload_size)) {
        if (old_payload_size < new_payload_size) {
            hgc_ptr new_payload = 
                MR_hgc_malloc_immutable(new_payload_size);
            hgc_int i;
            for (i = 0; i < old_payload_size; i++) {
                new_payload[i] = old_payload[i];
            }
            for (i = 0; i < mutables_array_num_occupants(mutables); i++) {
                if (mutables_array_get_item(mutables, i) == old_payload) {
                    mutables_array_set_item(mutables, i, new_payload);
                    break;
                }
            }
            for (
                i = 0;
                i < uncollectables_array_num_occupants(uncollectables);
                i++
            ) {
                if (uncollectables_array_get_item(uncollectables, i) ==
                        old_payload) {
                    uncollectables_array_set_item(uncollectables, i,
                            new_payload);
                    break;
                }
            }
            return new_payload;
        } else {
            return old_payload;
        }
    } else {
        fprintf(stderr, "hgc: hgc_realloc(): not an allocated cell.\n");
        exit(1);
    }
}

/*
** "Free" a cell by either NULLing its payload (small cells) or reducing
** its payload size to zero (big cells).
*/
void
MR_hgc_free(void *p)
{
    hgc_ptr cl;
    hgc_ptr payload;
    hgc_int payload_size;
    p = untag(p);
    if (find_small_cell(p, &cl, &payload, &payload_size)) {
        hgc_ptr payload_ptr;
        for (payload_ptr = payload; payload_ptr < payload + payload_size; payload_ptr++) {
            *payload_ptr = 0;
        }
        return;
    }
    if (find_big_cell(p, &cl, &payload, &payload_size)) {
        *big_cell_payload_size(cl) = 0;
        return;
    }
    fprintf(stderr, "hgc: hgc_free(): not an allocated cell.\n");
    exit(1);
}

#endif /* MR_HGC */
