File r38/lisp/csl/cslbase/gc.c artifact 9b0373da3d part of check-in 3af273af29


/* File gc.c                    Copyright (c) Codemist Ltd, 1990-2007 */

/*
 * Garbage collection.
 *    Version 5. The mark/slide code is being removed on the
 *    grounds that machines these days have LOTS of memory so ot should
 *    not really bbe needed, and it is a lot of messy code to support.
 *    there is also a start at support for a
 *    conservative garbage collector so that the separate C
 *    stack that I used to need is no longer called for: the hope is
 *    that this may seriously speed up much code... but it makes
 *    "cons" a little messier and "allocate_vector" a lot messier,
 *    and a somewhat-copying conservative GC hurts on the complication
 *    front quite a lot! That is enabled via --enable-conservative in
 *    that autoconf stuff, and is NOT working yet.
 *
 *    Fourth major version - now using Foster-style
 *    algorithm for relocating vector heap, and support for handling
 *    BPS via segmented handles. Pointer-reversing mark phase to go
 *    with same.
 *
 *    Furthermore there is (optionally) a copying 2-space garbage
 *    collector as well as the mark/slide one.  Now do you understand
 *    why this file seems so very long?
 *
 * The code in parts of this file (and also in preserve.c & restart.c)
 * is painfully sensitive to memory layout and I have some messy
 * conditional inclusion of code depending on whether a Lisp_Object is
 * a 32 or 64-bit value.
 */

/*
 * This code may be used and modified, and redistributed in binary
 * or source form, subject to the "CCL Public License", which should
 * accompany it. This license is a variant on the BSD license, and thus
 * permits use of code derived from this in either open and commercial
 * projects: but it does require that updates to this code be made
 * available back to the originators of the package.
 * Before merging other code in with this or linking this code
 * with other packages or libraries please check that the license terms
 * of the other material are compatible with those of this.
 */


/* Signature: 536448d8 19-Jan-2008 */

#include "headers.h"

#ifdef SOCKETS
#include "sockhdr.h"
#endif

int gc_number = 0;

static intptr_t cons_cells, symbol_heads, strings, user_vectors,
             big_numbers, box_floats, bytestreams, other_mem,
             litvecs, getvecs;

#define is_immed(x) (is_immed_or_cons(x) && !is_cons(x))

Lisp_Object MS_CDECL Lgc0(Lisp_Object nil, int nargs, ...)
{
    argcheck(nargs, 0, "reclaim");
    return Lgc(nil, lisp_true);
}

Lisp_Object Lgc(Lisp_Object nil, Lisp_Object a)
{
/*
 * If GC is called with a non-nil argument the garbage collection
 * will be a full one - otherwise it will be soft and may do hardly
 * anything.
 */
#ifdef DEMO_MODE
    return onevalue(nil);
#else
    return reclaim(nil, "user request",
                   a != nil ? GC_USER_HARD : GC_USER_SOFT, 0);
#endif
}

Lisp_Object Lverbos(Lisp_Object nil, Lisp_Object a)
/*
 * (verbos 0) or (verbos nil)       silent garbage collection
 * (verbos 1) or (verbos t)         standard GC messages
 * (verbos 2)                       messages when FASL module loaded
 * (verbos 4)                       extra timing info for GC process
 * These bits can be added to get combination effects, except that
 * "4" has no effect unless "1" is present.
 */
{
    int code, old_code = verbos_flag;
    if (a == nil) code = 0;
    else if (is_fixnum(a)) code = (int)int_of_fixnum(a);
    else code = 1;
/*
 * -G on the command line makes garbage collection noisy always...
 */
    if (miscflags & ALWAYS_NOISY) code |= 3;
    miscflags = (miscflags & ~GC_MSG_BITS) | (code & GC_MSG_BITS);
    return onevalue(fixnum_of_int(old_code));
}


CSLbool volatile already_in_gc, tick_on_gc_exit;
CSLbool volatile interrupt_pending, tick_pending;
Lisp_Object volatile saveheaplimit;
Lisp_Object volatile savevheaplimit;
Lisp_Object volatile savecodelimit;
Lisp_Object * volatile savestacklimit;


static int stop_after_gc = 0;

static void zero_out(void *p)
{
    char *p1 = (char *)doubleword_align_up((intptr_t)p);
    memset(p1, 0, CSL_PAGE_SIZE);
}

static int trailing_heap_pages_count,
           trailing_vheap_pages_count;

static void copy(Lisp_Object *p)
/*
 * This copies the object pointed at by p from the old to the new semi-space,
 * and returns a copy to the pointer.  If scans the copied material to copy
 * all relevent sub-structures to the new semi-space.
 */
{
    Lisp_Object nil = C_nil;
    char *fr = (char *)fringe, *vfr = (char *)vfringe;
    char *tr_fr = fr, *tr_vfr = vfr;
    void *p1;
#define CONT           0
#define DONE_CAR      -1
#define DONE_VALUE    -2
#define DONE_ENV      -3
#define DONE_PNAME    -4
#define DONE_PLIST    -5
#define DONE_FASTGETS -6
    int next = CONT;
    char *tr=NULL;
#ifdef DEBUG_GC
    term_printf("Copy [%p] %p\n", (void *)p, (void *)*p);
#endif
/*
 * The code here is a simulation of multiple procedure calls to the
 * code that copies a single object.  What might otherwise have been
 * a "return address" in the calls is handled by the variable "next" which
 * takes positive values while copying vectors, and negative ones in
 * the more common cases. I use "for (;;)" blocks a lot so that I can
 * use "break" and "continue" to leap around in the code - maybe I
 * would do better to be honest and use regular labels and "goto"
 * statements.
 */
    for (;;)
    {
/*
 * Copy one object, pointed at by p, from the old semi-space into the new
 * one.
 */
        Lisp_Object a = *p;
#ifdef DEBUG_GC
        term_printf("Next copy [%p] %p\n", (void *)p, (void *)a);
        if (a == 0)
        {   term_printf("Shambles\n");
            *(int *)(-1) = 0;
        }
#endif
        for (;;)
        {
            if (a == nil) break;    /* common and cheap enough to test here */
            else if (is_immed_or_cons(a))
            {   if (is_cons(a))
                {   Lisp_Object w;
                    w = qcar(a);
                    if (is_cons(w) && is_marked_p(w)) /* a forwarding address */
                    {   *p = flip_mark_bit_p(w);
                        break;
                    }
                    fr = fr - sizeof(Cons_Cell);
                    cons_cells += 2*CELL;
/*
 * When I am doing regular calculation I leave myself a bunch of spare
 * words (size SPARE bytes) so that I can afford to do several cons operations
 * between tests.  Here I do careful tests on every step, and so I can
 * sail much closer to the wind wrt filling up space.
 */
                    if (fr <= (char *)heaplimit - SPARE + 32)
                    {   char *hl = (char *)heaplimit;
                        void *p;
                        int32_t len = (int32_t)(fr - (hl - SPARE) +
                                                     sizeof(Cons_Cell));
                        car32(hl - SPARE) = len;
                        qcar(fr) = SPID_GCMARK;
                        if (pages_count == 0)
                        {   term_printf("pages_count = 0 in GC\n");
                            ensure_screen();
                            abort();
                            return;
                        }
                        p = pages[--pages_count];
                        zero_out(p);
                        new_heap_pages[new_heap_pages_count++] = p;
                        heaplimit = quadword_align_up((intptr_t)p);
                        hl = (char *)heaplimit;
                        car32(heaplimit) = CSL_PAGE_SIZE;
                        fr = hl + CSL_PAGE_SIZE - sizeof(Cons_Cell);
                        heaplimit = (Lisp_Object)(hl + SPARE);
                    }
                    qcar(fr) = w;
                    qcdr(fr) = qcdr(a);
#ifdef DEBUG_GC
                    term_printf("new data for cons %p %p\n", (void *)w, (void *)qcdr(a));
#endif
                    *p = w = (Lisp_Object)(fr + TAG_CONS);
                    qcar(a) = flip_mark_bit_p(w);
                    break;
                }   /* end of treatment of CONS */
                else if (is_bps(a))
                {   char *d = data_of_bps(a) - CELL, *rr;
                    int32_t alloc_size;
                    Header h = *(Header *)d;
                    int32_t len;
                    if (is_bps(h))  /* Replacement handle in header field? */
                    {   *p = h ;
                        break;
                    }
                    len = length_of_header(h);
                    alloc_size = doubleword_align_up(len);
                    bytestreams += alloc_size;
                    for (;;)
                    {   char *cf = (char *)codefringe,
                             *cl = (char *)codelimit;
                        int32_t free = (int32_t)(cf - cl);
                        if (alloc_size > free)
                        {
                            void *p;
                            if (codelimit != 0)
                            {   int32_t len = (int32_t)(cf - (cl - 8));
                                car32(cl - 8) = len;
                            }
                            if (pages_count == 0)
                            {   term_printf("pages_count = 0 in GC\n");
                                ensure_screen();
                                abort();
                                return;
                            }
                            p = pages[--pages_count];
                            zero_out(p);
                            new_bps_pages[new_bps_pages_count++] = p;
                            cl = (char *)doubleword_align_up((intptr_t)p);
                            codefringe = (Lisp_Object)(cl + CSL_PAGE_SIZE);
                            codelimit = (Lisp_Object)(cl + 8);
                            continue;
                        }
                        rr = cf - alloc_size;
                        codefringe = (Lisp_Object)rr;
/*
 * See comments in fns2.c for the curious packing here!
 */
                        *(Header *)d = *p = TAG_BPS +
                           (((intptr_t)((rr + CELL) - (cl - 8)) &
                             (PAGE_POWER_OF_TWO-4)) << 6) +
                           (((intptr_t)(new_bps_pages_count-1))<<(PAGE_BITS+6));
                        /* Wow! How obscure!! */
                        *(Header *)rr = h;
                        memcpy(rr+CELL, d+CELL, alloc_size-CELL);
                        break;
                    }
                    break;
                }
                else break;        /* Immediate data drops out here */
            }
            else                    /* Here I have a symbol or vector */
            {   Header h;
                int tag;
                intptr_t len;
                tag = ((int)a) & TAG_BITS;
                a = (Lisp_Object)((char *)a - tag);
                h = *(Header *)a;
#ifdef DEBUG_GC
                term_printf("Header is %p\n", (void *)h);
#endif
                if (!is_odds(h))
                {   *p = h;
                    break;
                }
                if (tag == TAG_SYMBOL)
                    len = symhdr_length, symbol_heads += symhdr_length;
                else
                {   len = doubleword_align_up(length_of_header(h));
                    switch (type_of_header(h))
                    {
                case TYPE_STRING:
                        strings += len; break;
                case TYPE_BIGNUM:
                        big_numbers += len; break;
#ifdef COMMON
                case TYPE_SINGLE_FLOAT:
                case TYPE_LONG_FLOAT:
#endif
                case TYPE_DOUBLE_FLOAT:
                        box_floats += len; break;
                case TYPE_SIMPLE_VEC:
                        user_vectors += len; break;
                default:
                        other_mem += len; break;
                    }
                }
                for (;;)
                {   char *vl = (char *)vheaplimit;
                    int32_t free = (int32_t)(vl - vfr);
                    if (len > free)
                    {   int32_t free1 =
                            (int32_t)(vfr - (vl - (CSL_PAGE_SIZE - 8)));
                        car32(vl - (CSL_PAGE_SIZE - 8)) = free1;
                        qcar(vfr) = 0;          /* sentinel value */
                        if (pages_count == 0)
                        {   term_printf("pages_count = 0 in GC\n");
                            ensure_screen();
                            abort();
                            return;
                        }
                        p1 = pages[--pages_count];
                        zero_out(p1);
                        new_vheap_pages[new_vheap_pages_count++] = p1;
                        vfr = (char *)doubleword_align_up((intptr_t)p1) + 8;
                        vl = vfr + (CSL_PAGE_SIZE - 16);
                        vheaplimit = (Lisp_Object)vl;
                        free1 = (uintptr_t)(vfr - (vl - (CSL_PAGE_SIZE - 8)));
                        car32(vl - (CSL_PAGE_SIZE - 8)) = free1;
                        continue;
                    }
                    *(Lisp_Object *)a = *p = (Lisp_Object)(vfr + tag);
                    *(Header *)vfr = h;
                    memcpy((char *)vfr+CELL, (char *)a+CELL, len-CELL);
                    vfr += len;
                    break;
                }
                break;
            }
        }
/*
 * Now I have copied one object - the next thing to do is to scan to see
 * if any further items are in the new space, and if so I will copy
 * their offspring.
 */
        for (;;)
        {
#ifdef DEBUG_GC
            switch (next)
            {
        case CONT:
                term_printf("next is CONT\n");
                break;
        case DONE_CAR:
                term_printf("next is DONE_CAR\n");
                break;
        case DONE_VALUE:
                term_printf("next is DONE_VALUE\n");
                break;
        case DONE_ENV:
                term_printf("next is DONE_ENV\n");
                break;
        case DONE_PNAME:
                term_printf("next is DONE_PNAME\n");
                break;
        case DONE_PLIST:
                term_printf("next is DONE_PLIST\n");
                break;
        case DONE_FASTGETS:
                term_printf("next is DONE_FASTGETS\n");
                break;
        default:
                term_printf("next is array offset %d = %x\n", next, next);
                break;
            }
#endif
            switch (next)
            {
        case CONT:
                if (tr_fr != fr)
                {   tr_fr = tr_fr - sizeof(Cons_Cell);
                    if (qcar(tr_fr) == SPID_GCMARK)
                    {   char *w;
                        p1 = new_heap_pages[trailing_heap_pages_count++];
                        w = (char *)quadword_align_up((intptr_t)p1);
                        tr_fr = w + (CSL_PAGE_SIZE - sizeof(Cons_Cell));
                    }
                    next = DONE_CAR;
                    p = &qcar(tr_fr);
                    break;              /* Takes me to the outer loop */
                }
                else if (tr_vfr != vfr)
                {   Header h;
                    h = *(Header *)tr_vfr;
                    if (h == 0)
                    {   char *w;
                        p1 = new_vheap_pages[trailing_vheap_pages_count++];
                        w = (char *)doubleword_align_up((intptr_t)p1);
                        tr_vfr = w + 8;
                        h = *(Header *)tr_vfr;
                    }
                    if (is_symbol_header(h))
                    {   next = DONE_VALUE;   
                        p = &(((Symbol_Head *)tr_vfr)->value);
                        break;
                    }
                    else
                    {   int32_t len = doubleword_align_up(length_of_header(h));
                        tr = tr_vfr;
                        tr_vfr = tr_vfr + len;
                        if (len == CELL)
                        {
/*
 * In a 64-bit world vectors are not padded to be an even number of cells,
 * and so a vector with no elements consists of just its header word. This
 * is best treated as if it contained binary because it certainly does not
 * contain any pointers, while the general code for handling vectors is
 * written on the assumption that every vector that contains pointers at
 * all contains at least one.
 */
#ifdef DEBUG_GC
                            term_printf("zero length vector in 64-bit world\n");
#endif
                            continue;
                        }
#ifdef DEBUG_GC
                        term_printf("header = %llx, type = %d/%x len = %d\n",
                           (long long)h, type_of_header(h), type_of_header(h), len);
#endif

                        switch (type_of_header(h))
                        {
#ifdef COMMON
                    case TYPE_SINGLE_FLOAT:
                    case TYPE_LONG_FLOAT:
#endif
                    case TYPE_DOUBLE_FLOAT:
                    case TYPE_BIGNUM:
                            continue;
                    case TYPE_MIXED1: case TYPE_MIXED2:
                    case TYPE_MIXED3: case TYPE_STREAM:
                            next = 2*CELL;
                            break;
/*
 * There is a slight delight here. The test "vector_holds_binary" is only
 * applicable if the header to be checked is a header of a genuine vector,
 * ie something that would have TAG_VECTOR in the pointer to it. But here
 * various numeric data types also live in the vector heap, so I need to
 * separate them out explicitly. The switch block here does slightly more than
 * it actually HAS to, since the vector_holds_binary test would happen to
 * deal with several of the numeric types "by accident", but I feel that
 * the security of listing them as separate cases is more important than the
 * minor speed-up that might come from exploiting such marginal behaviour.
 */
                    default:
                            if (vector_holds_binary(h)) continue;
#ifdef COMMON
                    case TYPE_RATNUM:
                    case TYPE_COMPLEX_NUM:
#endif
                            next = len - 2*CELL;
#ifdef DEBUG_GC
                            term_printf("line %d next now %d\n", __LINE__, next);
                            if (next < 0)
                            {   term_printf("unexpectedly negative\n");
/* Just a vector with no elements on a 64-bit system? */                                continue;
                            }
#endif
                            break;
                        }
                        p = (Lisp_Object *)(tr + next + CELL);
                        break;
                    }
                }
                else
                {   fringe = (Lisp_Object)fr;
                    vfringe = (Lisp_Object)vfr;
                    return;        /* Final exit when all has been copied */
                }
        case DONE_CAR:
                next = CONT;
                p = &qcdr(tr_fr);
                break;
        case DONE_VALUE:
                next = DONE_ENV;   
                p = &(((Symbol_Head *)tr_vfr)->env);
                break;
        case DONE_ENV:
                next = DONE_FASTGETS;   
                p = &(((Symbol_Head *)tr_vfr)->fastgets);
                break;
        case DONE_FASTGETS:
                next = DONE_PNAME;   
                p = &(((Symbol_Head *)tr_vfr)->pname);
                break;
        case DONE_PNAME:
#ifndef COMMON
                next = CONT;
                p = &(((Symbol_Head *)tr_vfr)->plist);
                tr_vfr = tr_vfr + symhdr_length;
                break;
#else
                next = DONE_PLIST;   
                p = &(((Symbol_Head *)tr_vfr)->plist);
                break;
        case DONE_PLIST:
                next = CONT;
                p = &(((Symbol_Head *)tr_vfr)->package);
                tr_vfr = tr_vfr + symhdr_length;
                break;
#endif
        default:
                p = (Lisp_Object *)(tr + next);
                next -= CELL;
#ifdef DEBUG_GC
                term_printf("line %d next now %d\n", __LINE__, next);
                if (next < 0)
                {   term_printf("unexpectedly negative\n");
                    *(int *)(-1) = 0;
                }
#endif
                break;
            }
            break;
        }
    }
}

#ifndef DEMO_MODE

typedef struct mapstore_item
{
    double w;
    double n;
    uint32_t n1;
    Lisp_Object p;
} mapstore_item;

int profile_count_mode;

static int MS_CDECL profile_cf(const void *a, const void *b)
{
    mapstore_item *aa = (mapstore_item *)a,
                  *bb = (mapstore_item *)b;
    
    if (profile_count_mode)
    {   if (aa->n1 == bb->n1) return 0;
	if (aa->n1 < bb->n1) return 1;
	else return -1;
    }
    if (aa->w == bb->w) return 0;
    else if (aa->w < bb->w) return 1;
    else return -1;
}

#endif

Lisp_Object Lmapstore(Lisp_Object nil, Lisp_Object a)
/*
 * Argument controls what happens:
 *    nil or 0      print statistics and reset to zero
 *           1      print, but do not reset
 *           2      return list of stats, reset to zero
 *           3      return list, do not reset
 *           4      reset to zero, do not print, return nil
 *	     8	    Toggle call count mode
 */
{
#ifdef DEMO_MODE
    return onevalue(nil);
#else
    int pass, what;
    int j, gcn = 0;
    double itotal = 0.0, total = 0.0;
    Lisp_Object res = nil;
    mapstore_item *buff=NULL;
    int buffp=0, buffn=0;
    if (a == nil) a = fixnum_of_int(0);
    if (is_fixnum(a)) what = int_of_fixnum(a);
    else what = 0;
    if ((what & 6) == 0)
    {   buff = (mapstore_item *)(*malloc_hook)(100*sizeof(mapstore_item));
        if (buff == NULL) return onevalue(nil); /* fail */
        buffp = 0;
        buffn = 100;
    }
    if ((what & 2) != 0)
    {   Lgc0(nil, 0); /* Force GC at start to avoid one in the middle */
        nil = C_nil;
        if (exception_pending()) return nil;
        gcn = gc_number;
    }

    if ((what & 8) != 0)
	profile_count_mode = !profile_count_mode;
#ifdef PROFILED
/*
 * PROFILED is intended to be defined if we were compiled with a -p option,
 * and we take system dependent action to dump out results (e.g. on some systems
 * it may be useful to invoke monitor() or moncontrol() here.
 */

#ifdef SHOW_COUNTS_AVAILABLE
    show_counts();
    write_profile("counts");   /* Useful if -px option to compiler */
#endif

#endif /* PROFILED */
    {   char *vf = (char *)vfringe,
             *vl = (char *)vheaplimit;
        int32_t len = (int32_t)(vf - (vl - (CSL_PAGE_SIZE - 8)));
/*
 * Set up the current page so I can tell where the active data is.
 */
        car32(vl - (CSL_PAGE_SIZE - 8)) = len;
    }
    for (pass=0; pass<2; pass++)
    {   for (j=0; j<vheap_pages_count; j++)
        {   void *page = vheap_pages[j];
            char *low = (char *)doubleword_align_up((intptr_t)page);
            char *high = low + car32(low);
            low += 8;
            while (low<high)
            {   Header h = *(Header *)low;
                if (is_symbol_header(h))
                {   Lisp_Object e = qenv(low + TAG_SYMBOL);
                    intptr_t clen = 0;
                    uintptr_t n;
                    if (is_cons(e))
                    {   e = qcar(e);
                        if (is_bps(e))
                        {   Header ch = *(Header *)(data_of_bps(e) - CELL);
                            clen = length_of_header(ch);
                        }
                    }
                    n = qcount(low + TAG_SYMBOL);
                    if (n != 0 && clen != 0)
                    {   double w = (double)n/(double)clen;
/*
 * Here I want a measure that will give a good idea of how worthwhile it
 * would be to compile the given function into C - what I have chosen is
 * a count of bytecodes executed scaled by the length
 * of the bytestream code defining the function.  This will cause "good value"
 * cases to show up best.  I scale this relative to the total across all
 * functions recorded to make the numbers less sensitive to details of
 * how I generate test cases.  For interest I also display the proportion
 * of actual bytecodes interpreted.  In each case I record these out of
 * a total of 100.0 (percent) to give comfortable ranges of numbers to admire.
 */
                        if (pass == 0) itotal += (double)n, total += w;
                        else
                        {   if (w/total > 0.00001 ||
                                (double)n/itotal > 0.0001)
                            {   if ((what & 6) == 0)
                                {   if (buffp == buffn)
                                    {   buffn += 100;
                                        buff = (mapstore_item *)
                                            (*realloc_hook)((void *)buff,
                                                    sizeof(mapstore_item)*buffn);
                                        if (buff == NULL) return onevalue(nil);
                                    }
                                    buff[buffp].w = 100.0*w/total;
                                    buff[buffp].n = 100.0*(double)n/itotal;
                                    buff[buffp].n1 = n;
                                    buff[buffp].p = (Lisp_Object)(low + TAG_SYMBOL);
                                    buffp++;
                                }
                                if ((what & 2) != 0)
                                {   Lisp_Object w1;
/* Result is a list of items ((name size bytes-executed) ...).
 * You might think that I needed to push res here - but I abort if there
 * is a GC, so it is not necessary after all.
 */
                                    w1 = list3((Lisp_Object)(low + TAG_SYMBOL),
                                              fixnum_of_int(clen),
                                              fixnum_of_int(n));
                                    nil = C_nil;
                                    if (exception_pending() || gcn != gc_number)
                                        return nil;
                                    res = cons(w1, res);
                                    nil = C_nil;
                                    if (exception_pending() || gcn != gc_number)
                                        return nil;
                                }
                            }
/*
 * Reset count unless 1 bit of arg is set
 */
                            if ((what & 1) == 0)
                                qcount(low + TAG_SYMBOL) = 0;
                        }
                    }
                    low += symhdr_length;
                }
                else low += (intptr_t)doubleword_align_up(length_of_header(h));
            }
        }
    }
    if ((what & 6) == 0)
    {   double running = 0.0;
        qsort((void *)buff, buffp, sizeof(buff[0]), profile_cf);
        trace_printf("\n  Value  %%bytes (So far) Bytecodes  Function name\n");
        for (j=0; j<buffp; j++)
        {   running += buff[j].n;
            trace_printf("%7.2f %7.2f (%6.2f) %9lu: ",
                buff[j].w, buff[j].n, running, (long unsigned)buff[j].n1);
            prin_to_trace(buff[j].p);
            trace_printf("\n");
        }
        trace_printf("\n");
        (*free_hook)((void *)buff);
    }
    return onevalue(res);
#endif /* DEMO_MODE */
}

Lisp_Object MS_CDECL Lmapstore0(Lisp_Object nil, int nargs, ...)
{
    argcheck(nargs, 0, "mapstore");
    return Lmapstore(nil, nil);
}

static CSLbool reset_limit_registers(intptr_t vheap_need,
                                     intptr_t bps_need,
                                     intptr_t native_need,
                                     CSLbool stack_flag)
/*
 * returns YES if after resetting the limit registers there was
 * enough space left for me to proceed. Return NO on failure, ie
 * need for a more genuine GC.
 */
{
    void *p;
    nil_as_base
    uintptr_t len;
    CSLbool full;
/*
 * I wonder about the next test - memory would only really be full
 * if there was enough LIVE data to fill all the available free pages,
 * but what is tested here is based on the possibility that all the
 * active pages are totally full.
 */
    full = (pages_count <=
             heap_pages_count + vheap_pages_count +
             bps_pages_count + native_pages_count);
    if (fringe <= heaplimit)
    {   if (full) return NO;
        p = pages[--pages_count];
        zero_out(p);
        heap_pages[heap_pages_count++] = p;
        heaplimit = quadword_align_up((intptr_t)p);
        car32(heaplimit) = CSL_PAGE_SIZE;
        fringe = (Lisp_Object)((char *)heaplimit + CSL_PAGE_SIZE);
        heaplimit = (Lisp_Object)((char *)heaplimit + SPARE);
    }
    {   char *vh = (char *)vheaplimit,
             *vf = (char *)vfringe;
        len = (uintptr_t)(vh - vf);
    }
    if (vheap_need > (intptr_t)len)
    {   char *vf, *vh;
        if (full) return NO;
        p = pages[--pages_count];
        zero_out(p);
        vheap_pages[vheap_pages_count++] = p;
        vf = (char *)doubleword_align_up((intptr_t)p) + 8;
        vfringe = (Lisp_Object)vf;
        vh = vf + (CSL_PAGE_SIZE - 16);
        vheaplimit = (Lisp_Object)vh;
        len = (uintptr_t)(vf - (vh - (CSL_PAGE_SIZE - 8)));
        car32(vh - (CSL_PAGE_SIZE - 8)) = len;
    }
    {   char *cl = (char *)codelimit,
             *cf = (char *)codefringe;
        len = (uintptr_t)(cf - cl);
    }
    if (bps_need != 0 && bps_need >= (intptr_t)len)
    {   char *cl;
        if (full || bps_pages_count >= MAX_BPS_PAGES - 1) return NO;
        p = pages[--pages_count];
        zero_out(p);
        bps_pages[bps_pages_count++] = p;
        cl = (char *)doubleword_align_up((intptr_t)p);
        codefringe = (Lisp_Object)(cl + CSL_PAGE_SIZE);
        codelimit = (Lisp_Object)(cl + 8);
    }
    if (native_need != 0)
    {   if (full || native_pages_count >= MAX_NATIVE_PAGES - 1) return NO;
        p = pages[--pages_count];
        zero_out(p);
        native_pages[native_pages_count++] = p;
        native_fringe = 8;
    }
    if (stack_flag) return (stack < stacklimit);
    else return YES;
}

static void tidy_fringes(void)
/*
 * heaplimit was SPARE bytes above the actual base of the page,
 * so the next line dumps fringe somewhere where it can be found
 * later on when needed while scanning a page of heap.  Similarly
 * vfringe is stashed away at the end of its page.
 */
{   nil_as_base
    char *fr = (char *)fringe,
         *vf = (char *)vfringe,
         *cf = (char *)codefringe,
         *hl = (char *)heaplimit,
         *vl = (char *)vheaplimit,
         *cl = (char *)codelimit;
    int32_t len = (int32_t)(fr - (hl - SPARE));
    car32(hl - SPARE) = len;
    len = (uintptr_t)(vf - (vl - (CSL_PAGE_SIZE - 8)));
    car32(vl - (CSL_PAGE_SIZE - 8)) = (Lisp_Object)len;
    if (codelimit != 0)
    {   len = (int32_t)(cf - (cl - 8));
        car32(cl - 8) = len;
    }
}

static void lose_dead_hashtables(void)
/*
 * This splices out from the list of hash tables all entries that point to
 * tables that have not been marked or copied this garbage collection.
 */
{
    Lisp_Object *p = &eq_hash_tables, q, r;
    while ((q = *p) != C_nil)
    {   Header h;
        r = qcar(q);
        h = vechdr(r);
        if (is_odds(h) && !is_marked_h(h)) *p = qcdr(q);
        else p = &qcdr(q);
    }
    p = &equal_hash_tables;
    while ((q = *p) != C_nil)
    {   Header h;
        r = qcar(q);
        h = vechdr(r);
        if (is_odds(h) && !is_marked_h(h)) *p = qcdr(q);
        else p = &qcdr(q);
    }
}

#ifdef DEMO_MODE

extern CSLbool terminal_pushed;

void give_up()
{
    Lisp_Object nil;
#define m(s) err_printf(s)
m("\n+++ DEMONSTRATION VERSION OF REDUCE - RESOURCE LIMIT EXCEEDED +++\n");
m("This version of REDUCE has been provided for testing and\n");
m("demonstration purposes.  It has a built-in cut-out that will\n");
m("terminate processing after a time that should be sufficient for\n");
m("various small tests to run, but which will probably stop it\n");
m("from being useful as a serious tool.  You are permitted to copy\n");
m("the demonstration version and pass it on to friends subject to\n");
m("not changing it, and in particular neither changing the various\n");
m("messages it prints nor attempting to circumvent the time-out\n");
m("mechanism.  Full versions of REDUCE are available to run on a\n");
m("wide range of types of computer, and a machine-readable file\n");
m("listing suppliers was provided with the documentation that goes\n");
m("with this version.  Some suppliers are:\n");
m("  Codemist Ltd, Alta, Horsecombe Vale, Combe Down, Bath BA2 5QR,\n");
m("    England.  Phone and fax +44-225-837430,\n");
m("    http://www.codemist.co.uk\n");
m("  Winfried Neun, Konrad-Zuse-Zentrum fuer Informationstechnik Berlin\n");
m("    Heilbronner Str. 10, D 10711 Berlin-Wilmersdorf, GERMANY\n");
m("    Phone: +44-30-89604-195  Fax +49-30-89604-125.\n");
m("  (Codemist provided this version, the ZIB differs slightly)\n");
m("<Close window/type RETURN to exit>\n");
#undef m
    nil = C_nil;
    prompt_thing = CHAR_EOF;    /* Disables the prompt */
    ensure_screen();
    terminal_pushed = NOT_CHAR;
    tty_count = 0;
    char_from_terminal(0);      /* intended to delay until a char is typed */
    my_exit(EXIT_FAILURE);
}

#endif

#ifdef HAVE_FWIN

/*
 * I need a way that a thread that is not synchronised with this one can
 * generate a Lisp-level interrupt. I achieve that by
 * letting that thread reset stacklimit. Then rather soon CSL will
 * do a stackcheck() and will call reclaim with type GC_STACK.
 *
 * call this with
 *    arg=0 to have no effect at all (!)   QUERY_INTERRUPT
 *    arg=1 for a clock tick event         TICK_INTERRUPT
 *    arg=2 for quiet unwind               QUIET_INTERRUPT
 *    arg=3 for backtrace.                 NOISY_INTERRUPT
 * in each case the previous value of the flag is returned. Note that
 * I do not do a "test-and-set" here so do NOT treat this as a proper
 * start at a mutex or semaphore! However if I apply a rule that the
 * asynchronous (GUI) task only ever sets the flag to a non-zero value
 * and only ever tests then to see if it has been reset to zero, while the
 * main worker thread only reads it to check for non-zero and then
 * resets it I have some degree of sanity.
 */

static volatile int async_type = QUERY_INTERRUPT;

int async_interrupt(int type)
{
    int prev = async_type;
    if (type != QUERY_INTERRUPT)
    {   async_type = type;
        stacklimit = stackbase;
    }
    return prev;
}

#endif

static void report_at_end(Lisp_Object nil)
{
#ifdef WINDOW_SYSTEM
    {   int n = heap_pages_count + vheap_pages_count + bps_pages_count;
        int n1 = n + pages_count;
        double z = (100.0*n)/n1;
        report_space(gc_number, z);
        if (verbos_flag & 1) trace_printf(
           "At gc end about %.1f Mbytes of %.1f (%.1f%%) of heap is in use\n",
           ((double)n)*(CSL_PAGE_SIZE/(1024.0*1024.0)),
           ((double)n1)*(CSL_PAGE_SIZE/(1024.0*1024.0)), z);
    }
#else
    if (verbos_flag & 1)
    {   int n = heap_pages_count + vheap_pages_count + bps_pages_count;
        int n1 = n + pages_count;
        trace_printf(
            "At gc end about %.1f Mbytes of %.1f (%.1f%%) of heap is in use\n",
            (double)n*(CSL_PAGE_SIZE/(1024.0*1024.0)),
            (double)n1*(CSL_PAGE_SIZE/(1024.0*1024.0)),
            (100.0*n)/n1);
    }
#endif
}

#ifdef CONSERVATIVE

/*
 * The conservative collector needs to cope with some ambiguous pointers.
 * these must all be marked from, but the data that they seem to point to
 * must not be moved since the pointer must not be changed in any way in
 * case it is in fact not a pointer. To support that I need to be ready
 * to track and record all the ambiguous roots. I will use a hash table
 * as part of this process.
 */ 

Lisp_Object *C_stackbase, *C_stacktop;

void get_stacktop()
{
    volatile Lisp_Object sp;
    C_stacktop = (Lisp_Object *)&sp;
}

/*
 * I want the following number to be a prime to make some hash-table
 * activity work smoothly.
 * the LOAD value is to let the hash table become 7/8 full before I
 * give up on it.
 */
#define AMBIGUOUS_CACHE_SIZE 2003U
#define AMBIGUOUS_LOAD   ((7*AMBIGUOUS_CACHE_SIZE)/8)

static Lisp_Object ambiguous[AMBIGUOUS_CACHE_SIZE];
static int nambiguous;
static Lisp_Object *C_stack_remaining;

static CSLbool certainly_not_valid(Lisp_Object p)
{
    switch (p & (GC_BIT_P | 0x7))
    {
case TAG_CONS:

case TAG_SYMBOL:
case TAG_NUMBERS:
case TAG_VECTOR:
case TAG_BOXFLOAT:

default:
        return YES;
    }
}

typedef void process_ambiguous_pointer_t(Lisp_Object x);

static void scan_ambiguous(process_ambiguous_pointer_t *fn)
{
    unsigned int i;
    Lisp_Object *s;
    for (i=0; i<AMBIGUOUS_CACHE_SIZE; i++)
    {   Lisp_Object p = ambiguous[i];
        if (p == 0) continue;
        (*fn)(p);
    }
    for (s=C_stack_remaining; s<=C_stackbase; s++)
    {   Lisp_Object p = *s;
        if (certainly_not_valid(p)) continue;
        (*fn)(p);
    }
}

static void cache_ambiguous()
{
/*
 * This sets up my hash table of ambiguous pointers and MUST be called before
 * I use scan_ambiguous.
 */
    unsigned int i;
    Lisp_Object *s;
    for (i=0; i<AMBIGUOUS_CACHE_SIZE; i++) ambiguous[i] = 0;
    nambiguous = 0;
    for (s=C_stacktop; s<=C_stackbase && nambiguous<AMBIGUOUS_LOAD; s++)
    {   Lisp_Object p = *s;
        if (certainly_not_valid(p)) continue;
        i = (unsigned int)(((uintptr_t)p) % (uintptr_t)AMBIGUOUS_CACHE_SIZE);
        for (;;)
        {   if (ambiguous[i] == 0)
            {   ambiguous[i] = p;   /* enter new pointer into the table */
                nambiguous++;       /* count entries in the table */
                break;
            }
            else if (ambiguous[i] == p) break; /* seen before */
/*
 * I make my stride through the hash table depend on the value too, but
 * by having a table whose size is prime I will always eventually look in
 * every location.
 */
            i += 1 + (int)(((uintptr_t)p) %
                            (uintptr_t)(AMBIGUOUS_CACHE_SIZE-2));
        }
    }
}

#endif /* CONSERVATIVE */

Lisp_Object use_gchook(Lisp_Object p, Lisp_Object arg)
{
    Lisp_Object nil = C_nil;
    Lisp_Object g = gchook;
    if (symbolp(g) && g != unset_var)
    {   g = qvalue(g);
        if (symbolp(g) && g != unset_var)
        {   push(p);
            Lapply1(nil, g, arg);  /* Call the hook */
            errexitn(1);      /* the hook function failed */
            pop(p);
        }
    }
    return onevalue(p);
}

Lisp_Object reclaim(Lisp_Object p, char *why, int stg_class, intptr_t size)
{
    intptr_t i;
    clock_t t0, t1, t2, t3;
    Lisp_Object *sp, nil = C_nil;
    intptr_t vheap_need = 0, bps_need = 0, native_need = 0;
#ifdef DEBUG_GC
    term_printf("Start of a garbage collection %d\n", gc_number);
#endif
#ifdef CONSERVATIVE
/*
 * How do I know that all callee-save registers are on the stack by the
 * stage that I get to the level that C_stacktop now refers to???
 */
    get_stacktop();
    trace_printf("\n=== C stack size = %5d\n", (C_stackbase-C_stacktop)); 
    trace_printf("\n=== C_stackbase=%p C_stacktop=%p\n",
                        (void *)C_stackbase, (void *)C_stacktop); 
#endif /* CONSERVATIVE */
    stop_after_gc = 0;
    if (stg_class == GC_VEC) vheap_need = size;
    else if (stg_class == GC_BPS) bps_need = size;
    else if (stg_class == GC_NATIVE) native_need = size;
    already_in_gc = YES;
#ifdef WIN32
    _kbhit(); /* Fairly harmless anyway, but is here to let ^c get noticed */
/*    printf("(*)"); fflush(stdout);  /* while I debug! */
#endif
#ifdef SOCKETS
    if (socket_server != 0)
    {   time_t tt0 = time(NULL);
        t0 = clock();
        tt0 = time(NULL);
        if (t0 > cpu_timeout ||
            tt0 > elapsed_timeout)
        {   cpu_timeout = t0 + 20;
            elapsed_timeout = tt0 + 20;
            term_printf("\nSorry: timeout on this session. Closing down\n");
            return Lstop(nil, fixnum_of_int(1));
        }
    }
#endif

    push_clock(); t0 = base_time;

#ifdef HAVE_FWIN
/*
 * Life is a bit horrid here. I can have two significantly different sorts of
 * thing that cause this soft-GC to happen under FWIN. One is when I am in
 * windowed mode and FWIN provokes an asynchronous event for me. The other is
 * in non-windowed mode when my software_ticks counter overflows and does
 * a somewhat similar job... but from within this worker thread. The really
 * bad news is the thought of both of these active together, and so conflict
 * and confusion. Fresh and careful thought about that is needed before I
 * re-work this code.
 *
 * In non-windowed mode a problem I have is the detection of ^C interrupts.
 * Under Windows I have used SetConsoleMode (and under Unix/Linux tcsetattr)
 * to put the input into raw mode if it is direct from a keyboard. Thus
 * the operating system will not process ^C for me.
 */
    if (stg_class == GC_STACK && stacklimit == stackbase)
    {   stacklimit = savestacklimit;
        if (tick_pending)
        {   tick_pending = 0;
            heaplimit = saveheaplimit;
	    vheaplimit = savevheaplimit;
	    codelimit = savecodelimit;
	    stacklimit = savestacklimit;
        }
        tidy_fringes();
        already_in_gc = NO;
        pop_clock();
/*
 * There could, of course, be another async interrupt generated even during
 * this processing and certainly by the time I get into interrupted(),
 * and there could be "genuine" need for garbage collection or stack overflow
 * processing at any stage.
 */
        if (exception_pending()) nil = nil ^ 1;
        if (async_type == TICK_INTERRUPT)
        {   long int t = (long int)(100.0 * consolidated_time[0]);
            long int gct = (long int)(100.0 * gc_time);
            async_type = QUERY_INTERRUPT;     /* accepted! */
            fwin_acknowledge_tick();
            report_time(t, gct);
            return onevalue(p);
        }
        else if (async_type == NOISY_INTERRUPT)
            miscflags |= HEADLINE_FLAG | MESSAGES_FLAG;
        else miscflags &= ~MESSAGES_FLAG;
        async_type = QUERY_INTERRUPT;     /* accepted! */
        return interrupted(p);
    }
    else
#else /* HAVE_FWIN */
	if (interrupt_pending)
	{   if (tick_pending)
            {   tick_pending = 0;
                heaplimit = saveheaplimit;
	        vheaplimit = savevheaplimit;
	        codelimit = savecodelimit;
	        stacklimit = savestacklimit;
            }
	    tidy_fringes();
	    interrupt_pending = NO;
	    pop_clock();
	    return interrupted(p);
	}
#endif /* HAVE_FWIN */
    {   tidy_fringes();
        if (stg_class != GC_PRESERVE &&
            stg_class != GC_USER_HARD &&
            reset_limit_registers(vheap_need, bps_need, native_need, YES))
        {   already_in_gc = NO;
            pop_clock();
            return use_gchook(p, nil); /* Soft GC */
        }
    }

    if (stack >= stacklimit)
    {    if (stacklimit != stackbase)
        {   stacklimit = &stacklimit[50];  /* Allow a bit of slack */
            pop_clock();
            return error(0, err_stack_overflow);
        }
    }

#ifdef MEMORY_TRACE
#ifndef CHECK_ONLY
    identify_page_types();
    memory_comment(4);
#endif
#endif

#ifdef DEMO_MODE
    give_up();
    pop_clock();
    return nil;
#else
    push(p);

    gc_number++;

#ifdef WINDOW_SYSTEM
/*
 * If I have a window system I tell it the current time every so often
 * just to keep things cheery...
 */
    {   long int t = (long int)(100.0 * consolidated_time[0]);
        long int gct = (long int)(100.0 * gc_time);
/* /*
 * I guess that I want garbage collection messages, if any, to
 * be sent to stderr rather than whatever output stream happens to
 * be selected at the time of the garbage collection?
 * At present messages go to the normal output stream, which only makes
 * sense if GC messages are almost always disabled - maybe that will
 * be the case!
 */
        report_time(t, gct);
        if (verbos_flag & 1)
        {   freshline_trace();
            trace_printf(
        "+++ Garbage collection %ld (%s) after %ld.%.2ld+%ld.%.2ld seconds\n",
                 (long)gc_number, why, t/100, t%100, gct/100, gct%100);
        }
    }
#else
    if (verbos_flag & 1)
    {   long int t = (long int)(100.0 * consolidated_time[0]);
        long int gct = (long int)(100.0 * gc_time);
/* /* I guess that I want garbage collection messages, if any, to
 * be sent to stderr rather than whatever output stream happens to
 * be selected at the time of the garbage collection?
 * At present messages go to the normal output stream, which only makes
 * sense if GC messages are almost always disabled - maybe that will
 * be the case!
 */
        freshline_trace();
        trace_printf(
         "+++ Garbage collection %ld (%s) after %ld.%.2ld+%ld.%.2ld seconds\n",
         (long)gc_number, why, t/100, t%100, gct/100, gct%100);
    }
#endif
/*
 * If things crash really badly maybe I would rather have my output up
 * to date.
 */
    ensure_screen();
    nil = C_nil;
    if (exception_pending())
    {   stop_after_gc = 1;
        flip_exception();
    }
    if (spool_file != NULL) fflush(spool_file);

#ifdef CONSERVATIVE
/*
 * if stg_class==GC_PRESERVE I will not need to process the C stack and
 * the Lisp stack ought to be empty. Otherwise here is where I start to
 * capture the set of ambiguous pointers that are in play.
 */
    if (stg_class != GC_PRESERVE)
    {   cache_ambiguous();
    }
#endif /* CONSERVATIVE */

    copy_into_nilseg(NO);

    cons_cells = symbol_heads = strings = user_vectors =
             big_numbers = box_floats = bytestreams = other_mem =
             litvecs = getvecs = 0;

/*
 * Here I need to sort of what sort of GC I should do. In the new world
 * here I should do a conservative mostly-copying one most of the time, but
 * the GC from "preserve" can afford to be a full and proper one that
 * does not worry about junk on the C stack, that can assume everything it
 * finds in a List Base is a valid Lisp object and so it can compact
 * perfectly.
 */

    t2 = t1 = t0;   /* Time is not split down in this case */
/*
 * Set up the new half-space initially empty.
 */
    new_heap_pages_count = 0;
    new_vheap_pages_count = 0;
    new_bps_pages_count = 0;
    trailing_heap_pages_count = 1;
    trailing_vheap_pages_count = 1;
    {   void *pp = pages[--pages_count];
        char *vf, *vl;
        int32_t len;
/*
 * A first page of (cons-)heap
 */
        zero_out(pp);
        new_heap_pages[new_heap_pages_count++] = pp;
        heaplimit = quadword_align_up((intptr_t)pp);
        car32(heaplimit) = CSL_PAGE_SIZE;
        vl = (char *)heaplimit;
        fringe = (Lisp_Object)(vl + CSL_PAGE_SIZE);
        heaplimit = (Lisp_Object)(vl + SPARE);
#ifdef DEBUG_GC
        term_printf("fr = %p, hl = %p\n", (void *)fringe, (void *)heaplimit);
#endif
/*
 * A first page of vector heap.
 */
        pp = pages[--pages_count];
        zero_out(pp);
        new_vheap_pages[new_vheap_pages_count++] = pp;
        vf = (char *)doubleword_align_up((intptr_t)pp) + 8;
        vfringe = (Lisp_Object)vf;
        vl = vf + (CSL_PAGE_SIZE - 16);
        vheaplimit = (Lisp_Object)vl;
        len = (int32_t)(vf - (vl - (CSL_PAGE_SIZE - 8)));
        car32(vl - (CSL_PAGE_SIZE - 8)) = len;
/*
 * The BPS heap can start of utterly non-existent.
 */
        codefringe = codelimit = 0;
    }

/*
 * The very first thing that I will copy will be the main object-vector,
 * this is done early to ensure that it gets a full empty page of vector
 * heap to fit into.
 */
#ifdef DEBUG_GC
    term_printf("About to copy the object vector\n");
#endif
    copy(&BASE[current_package_offset]);
/*
 * The above line is "really"
 *          copy(&current_package);
 * but I use an offset into the nilseg in explicit form because otherwise
 * there is a big foul-up with the NILSEG_EXTERNS option...  Sorry!
 */

/*
 * I should remind you, gentle reader, that the value cell
 * and env cells of nil will always contain nil, which does not move,
 * and so I do not need to copy them here.
 */
#ifdef DEBUG_GC
    term_printf("About to copy NIL\n");
#endif
    copy(&(qplist(nil)));
    copy(&(qpname(nil)));
    copy(&(qfastgets(nil)));
#ifdef COMMON
    copy(&(qpackage(nil)));
#endif

/*
 * I dislike the special treatment of current_package that follows. Maybe
 * I should arrange something totally different for copying the package
 * structure...
 */
    for (i = first_nil_offset; i<last_nil_offset; i++)
        if (i != current_package_offset)
        {
        /* current-package - already copied by hand */
#ifdef DEBUG_GC
            term_printf("About to copy list-base %d\n", i);
#endif
            copy(&BASE[i]);
        }

#ifdef DEBUG_GC
    term_printf("About to copy the stack\n");
#endif
    for (sp=stack; sp>(Lisp_Object *)stackbase; sp--) copy(sp);
#ifdef DEBUG_GC
    term_printf("Stack processed\n");
#endif
/*
 * Now I need to perform some magic on the list of hash tables...
 */
    lose_dead_hashtables();
#ifdef DEBUG_GC
    term_printf("About to copy eq hash tables\n");
#endif
    copy(&eq_hash_tables);
#ifdef DEBUG_GC
    term_printf("About to copy equal hash tables\n");
#endif
    copy(&equal_hash_tables);

#ifdef DEBUG_GC
    term_printf("About to tidy fringes and finish up\n");
#endif
    tidy_fringes();

/*
 * Throw away the old semi-space - it is now junk.
 */
    while (heap_pages_count!=0)
        pages[pages_count++] = heap_pages[--heap_pages_count];
    while (vheap_pages_count!=0)
        pages[pages_count++] = vheap_pages[--vheap_pages_count];
    while (bps_pages_count!=0)
        pages[pages_count++] = bps_pages[--bps_pages_count];

/*
 * Flip the descriptors for the old and new semi-spaces.
 */
    {   void **w = heap_pages;
        heap_pages = new_heap_pages;
        new_heap_pages = w;
        w = vheap_pages;
        vheap_pages = new_vheap_pages;
        new_vheap_pages = w;
        w = bps_pages;
        bps_pages = new_bps_pages;
        new_bps_pages = w;
        heap_pages_count = new_heap_pages_count;
        new_heap_pages_count = 0;
        vheap_pages_count = new_vheap_pages_count;
        new_vheap_pages_count = 0;
        bps_pages_count = new_bps_pages_count;
        new_bps_pages_count = 0;
    }

    {   Lisp_Object qq;
/*
 * Note that EQUAL hash tables do not need to be rehashed here, though
 * they do if a heap image is exported from one system to another.
 */
        for (qq = eq_hash_tables; qq!=nil; qq=qcdr(qq))
            rehash_this_table(qcar(qq));
    }

    gc_time += pop_clock();
    t3 = base_time;

    copy_out_of_nilseg(NO);

    if ((verbos_flag & 5) == 5)
/*
 * (verbos 4) gets the system to tell me how long each phase of GC took,
 * but (verbos 1) must be ORd in too.
 */
    trace_printf("Copy %ld ms\n",
        (long int)(1000.0 * (double)(t3-t0)/(double)CLOCKS_PER_SEC));

/* (verbos 5) causes a display breaking down how space is used */
    if ((verbos_flag & 5) == 5)
    {   trace_printf(
            "cons_cells=%d, symbol_heads=%d, strings=%d, user_vectors=%d\n",
             cons_cells, symbol_heads, strings, user_vectors-litvecs-getvecs);
        trace_printf(
            "bignums=%d, floats=%d, bytestreams=%d, other=%d, litvecs=%d\n",
            big_numbers, box_floats, bytestreams, other_mem, litvecs);
        trace_printf("getvecs=%d\n", getvecs);
    }

    pop(p);

    if (!reset_limit_registers(vheap_need, bps_need, native_need, NO))
    {   if (stack < stacklimit || stacklimit != stackbase)
        {   report_at_end(nil);
            term_printf("\n+++ No space left at all\n");
            my_exit(EXIT_FAILURE);    /* totally drastic... */
        }
    }
#ifndef MEMORY_TRACE
/*
 * Here I grab more memory (if I am allowed to).
 * An initial version here, and one still suitable on machines that will
 * have plenty of real memory, will be to defined ok_to_grab_memory(n) as
 * 3*n + 2. This expands until the proportion of the heap active at the
 * end of garbage collection is less than 1/4.
 * If the attempt to grab more memory fails I clear the bit in init_flags
 * that allows me to try to expand, so I will not waste time again.  If
 * HOLD_BACK_MEMORY was asserted (for machines where grabbing all seemingly
 * available memory may cause a crash) I do not try this operation.  The
 * aim of keeping the heap less than half full is an heuristic and could be
 * adjusted on the basis of experience with this code.
 * The "+2" at the end of calculating the ideal heap size is intended
 * to keep us (mostly) in the copying GC domain.  If it is omitted the
 * heap tends to stay just 25% full and sliding GC is used. Overall this is
 * roughly as expensive as copying, but it is more disruptive since it comes
 * in larger gulps.
 * On systems where it is possible to measure the amount of available
 * real memory more sophisticated calculations may be possible.
 */
    if (init_flags & INIT_EXPANDABLE)
    {   int ideal = ok_to_grab_memory(heap_pages_count +
                                      vheap_pages_count +
                                      bps_pages_count);
        int more;
        if (ideal > MAX_PAGES) ideal = MAX_PAGES;
        more = ideal - pages_count;
        while (more-- > 0)
        {   void *page = (void *)my_malloc((size_t)(CSL_PAGE_SIZE + 8));
            intptr_t pun, pun1;
/*
 * When I first grabbed memory in restart.c I used my_malloc_1(), which
 * gobbles a large stack frame and then called regular malloc - the idea
 * there was to avoid malloc grabbing space needed for the stack. I can
 * not properly do that here since reclaim() may be called with a deep
 * stack already active.  There is thus a danger that expanding the heap here
 * may cause me to run out of stack elsewhere.  Oh well, I guess I can not
 * win in all ways.
 */
/*
 * Verify that new block does not span zero & has correct sign bit
 */
            pun = (intptr_t)page;
            pun1 = (intptr_t)((char *)page + CSL_PAGE_SIZE + 8);
            if ((pun ^ pun1) < 0) page = NULL;
            if ((pun + address_sign) < 0) page = NULL;
            if (page == NULL)
            {   init_flags &= ~INIT_EXPANDABLE;
                break;
            }
            else pages[pages_count++] = page;
        }
    }
#endif /* MEMORY_TRACE */
    report_at_end(nil);
    if (stop_after_gc)
    {
#ifdef MEMORY_TRACE
#ifndef CHECK_ONLY
        memory_comment(15);
#endif
#endif
        return Lstop(nil, fixnum_of_int(0));
    }
#ifdef MEMORY_TRACE
#ifndef CHECK_ONLY
    memory_comment(15);
#endif
#endif
    if (interrupt_pending)
    {   interrupt_pending = NO;
        already_in_gc = NO;
        tick_on_gc_exit = NO;
        return interrupted(p);
    }
    already_in_gc = NO;
    return use_gchook(p, lisp_true);
#endif /* DEMO_MODE */
}

/* end of file gc.c */


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]