Logo Search packages:      
Sourcecode: ecl version File versions  Download package

gbc.d

/*
    gbc.c -- Garbage collector.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi and William F. Schelter.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    ECL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/

#ifdef ECL_THREADS
#include <pthread.h>
#endif
#include <ecl/ecl.h>
#include <ecl/page.h>
#include <ecl/internal.h>
#include <ecl/bytecodes.h>

/******************************* EXPORTS ******************************/

bool GC_enable;

/******************************* ------- ******************************/

/*
   mark_table[m]:i represents word w = 128*m + 4*i, where m = addr-DATA_START.
   Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f.
*/

static int  *mark_table;

#define MTbit(x)  ((ptr2int(x) >> 2) & 0x1f)
#define MTword(x) mark_table[((cl_ptr)x - heap_start) >> 7]
#define get_mark_bit(x) (MTword(x) >> MTbit(x) & 1)
#define set_mark_bit(x) (MTword(x) |= (1 << MTbit(x)))
#define clear_mark_bit(x) (MTword(x) ~= (~1 << MTbit(x)))

#define VALID_DATA_ADDRESS(pp) \
  (!IMMEDIATE(pp) && (heap_start <= (cl_ptr)(pp)) && ((cl_ptr)(pp) < heap_end))

static bool debug = FALSE;
static int  maxpage;

#define     GC_ROOT_MAX       200
static cl_object  *gc_root[GC_ROOT_MAX];
static int  gc_roots;

static bool collect_blocks;

static int gc_time;                 /* Beppe */

/*
   We must register location, since value may be reassigned (e.g. malloc_list)
 */

static void _mark_object(cl_object x);
static void _mark_contblock(void *p, cl_index s);
static void mark_cl_env(struct cl_env_struct *env);
extern void sigint (void);

void
ecl_register_root(cl_object *p)
{
      if (gc_roots >= GC_ROOT_MAX)
            error("too many roots");
      gc_root[gc_roots++] = p;
}

cl_object
si_gc(cl_object area)
{
      if (!GC_enabled())
            error("GC is not enabled");
      if (Null(area))
            ecl_gc(t_cons);
      else
            ecl_gc(t_contiguous);
      @(return)
}

/*----------------------------------------------------------------------
 * Mark phase
 *----------------------------------------------------------------------
 */

/* Whenever two arrays are linked together by displacement,
   if one is live, the other will be made live */
#define mark_displaced(ar) mark_object(ar)
#define mark_contblock(x,s) {if (collect_blocks) _mark_contblock(x,s); }
#if 1
#define mark_object(x) if ((x != OBJNULL) && !IMMEDIATE(x)) _mark_object(x)
#define mark_next(a) if ((a != OBJNULL) && !IMMEDIATE(a)) { x=(a); goto BEGIN; }
#else
#define mark_object(x) _mark_object(x)
#define mark_next(a) x=(a); goto BEGIN
#endif

/* We make bitvectors multiple of sizeof(int) in size allocated
 Assume 8 = number of bits in char */
#define W_SIZE (8*sizeof(int))

static void
_mark_object(cl_object x)
{
      cl_index i, j;
      cl_object *p, y;
      cl_ptr cp;
BEGIN:
#if 0
      /* We cannot get here because mark_object() and mark_next() already check this */
      if (IMMEDIATE(x)) return;     /* fixnum, character or locative */
      if (x == OBJNULL)
            return;
#endif
      if (x->d.m) {
        if (x->d.m == FREE)
          error("mark_object: pointer to free object.");
        else
          return;
      }
      x->d.m = TRUE;

      switch (type_of(x)) {

      case t_bignum: {
#ifdef WITH_GMP
            /* GMP may set num.alloc before actually allocating anything.
               With these checks we make sure we do not move anything
               we don't have to. Besides, we use big_dim as the size
               of the object, because big_size might even be smaller.
            */
            cl_ptr limbs = (cl_ptr)x->big.big_limbs;
            cl_index size = x->big.big_dim * sizeof(mp_limb_t);
            if (size) mark_contblock(limbs, size);
#endif /* WITH_GMP */
            break;
      }
      case t_ratio:
            mark_object(x->ratio.num);
            mark_next(x->ratio.den);
            break;

      case t_shortfloat:
      case t_longfloat:
            break;

      case t_complex:
            mark_object(x->complex.imag);
            mark_next(x->complex.real);
            break;

      case t_character:
            break;

      case t_symbol:
            mark_object(x->symbol.hpack);
            mark_object(x->symbol.name);
            mark_object(x->symbol.plist);
            mark_object(x->symbol.gfdef);
            mark_next(x->symbol.value);
            break;

      case t_package:
            mark_object(x->pack.name);
            mark_object(x->pack.nicknames);
            mark_object(x->pack.shadowings);
            mark_object(x->pack.uses);
            mark_object(x->pack.usedby);
            mark_object(x->pack.internal);
            mark_next(x->pack.external);
            break;

      case t_cons:
            mark_object(CAR(x));
            mark_next(CDR(x));
            break;

      case t_hashtable:
            mark_object(x->hash.rehash_size);
            mark_object(x->hash.threshold);
            if (x->hash.data == NULL)
                  break;
            for (i = 0, j = x->hash.size;  i < j;  i++) {
                  mark_object(x->hash.data[i].key);
                  mark_object(x->hash.data[i].value);
            }
            mark_contblock(x->hash.data, j * sizeof(struct ecl_hashtable_entry));
            break;

      case t_array:
            mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank);
#ifdef ECL_UNICODE
      case t_string:
#endif
      case t_vector:
            if ((y = x->array.displaced) != Cnil)
                  mark_displaced(y);
            cp = (cl_ptr)x->array.self.t;
            if (cp == NULL)
                  break;
            switch ((cl_elttype)x->array.elttype) {
#ifdef ECL_UNICODE
            case aet_ch:
#endif
            case aet_object:
                  if (x->array.displaced == Cnil || CAR(x->array.displaced) == Cnil) {
                        i = x->vector.dim;
                        p = x->array.self.t;
                        goto MARK_DATA;
                  }
                  j = sizeof(cl_object)*x->array.dim;
                  break;
            case aet_bc:
                  j = x->array.dim;
                  break;
            case aet_bit:
                  j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE);
                  break;
            case aet_fix:
                  j = x->array.dim * sizeof(cl_fixnum);
                  break;
            case aet_index:
                  j = x->array.dim * sizeof(cl_index);
                  break;
            case aet_sf:
                  j = x->array.dim * sizeof(float);
                  break;
            case aet_lf:
                  j = x->array.dim * sizeof(double);
                  break;
            case aet_b8:
                  j = x->array.dim * sizeof(uint8_t);
                  break;
            case aet_i8:
                  j = x->array.dim * sizeof(int8_t);
                  break;
            default:
                  error("Allocation botch: unknown array element type");
            }
            goto COPY_ARRAY;
      case t_base_string:
            if ((y = x->base_string.displaced) != Cnil)
                  mark_displaced(y);
            cp = x->base_string.self;
            if (cp == NULL)
                  break;
            j = x->base_string.dim+1;
      COPY_ARRAY:
            mark_contblock(cp, j);
            break;
      case t_bitvector:
            if ((y = x->vector.displaced) != Cnil)
                  mark_displaced(y);
            cp = x->vector.self.bit;
            if (cp == NULL)
                  break;
            j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE);
            goto COPY_ARRAY;

#ifndef CLOS
      case t_structure:
            mark_object(x->str.name);
            p = x->str.self;
            i = x->str.length;
            goto MARK_DATA;
#endif /* CLOS */

      case t_stream:
            switch ((enum ecl_smmode)x->stream.mode) {
            case smm_input:
            case smm_output:
            case smm_io:
            case smm_probe:
                  mark_contblock(x->stream.buffer, BUFSIZ);
                  mark_object(x->stream.object0);
                  mark_next(x->stream.object1);
                  break;

            case smm_synonym:
                  mark_next(x->stream.object0);
                  break;

            case smm_broadcast:
            case smm_concatenated:
                  mark_next(x->stream.object0);
                  break;

            case smm_two_way:
            case smm_echo:
                  mark_object(x->stream.object0);
                  mark_next(x->stream.object1);
                  break;

            case smm_string_input:
            case smm_string_output:
                  mark_next(x->stream.object0);
                  break;

            default:
                  error("mark stream botch");
            }
            break;

      case t_random:
            break;

      case t_readtable:
            if (x->readtable.table == NULL)
                  break;
            mark_contblock((cl_ptr)(x->readtable.table),
                         RTABSIZE*sizeof(struct ecl_readtable_entry));
            for (i = 0;  i < RTABSIZE;  i++) {
                  cl_object *p = x->readtable.table[i].dispatch_table;
                  mark_object(x->readtable.table[i].macro);
                  if (p != NULL) {
                    mark_contblock(p, RTABSIZE*sizeof(cl_object));
                    for (j = 0;  j < RTABSIZE;  j++)
                      mark_object(p[j]);
                  }
            }
            break;

      case t_pathname:
            mark_object(x->pathname.host);
            mark_object(x->pathname.device);
            mark_object(x->pathname.version);
            mark_object(x->pathname.name);
            mark_object(x->pathname.type);
            mark_next(x->pathname.directory);
            break;

      case t_bytecodes:
            mark_object(x->bytecodes.name);
            mark_object(x->bytecodes.lex);
            mark_object(x->bytecodes.specials);
            mark_object(x->bytecodes.definition);
            mark_contblock(x->bytecodes.code, x->bytecodes.code_size * sizeof(cl_opcode));
            p = x->bytecodes.data;
            i = x->bytecodes.data_size;
            goto MARK_DATA;

      case t_cfun:
            mark_object(x->cfun.block);
            mark_next(x->cfun.name);
            break;

      case t_cclosure:
            mark_object(x->cfun.block);
            mark_next(x->cclosure.env);
            break;

#ifdef ECL_THREADS
      case t_process:
/* Already marked by malloc: x->process.env
 */
            mark_object(x->process.name);
            mark_object(x->process.interrupt);
            mark_object(x->process.function);
            mark_cl_env(x->process.env);
            mark_next(x->process.args);
            break;
      case t_lock:
            mark_next(x->lock.name);
            break;
#endif /* THREADS */
#ifdef CLOS
      case t_instance:
            mark_object(x->instance.clas);
            mark_object(x->instance.sig);
            p = x->instance.slots;
            i = x->instance.length;
            goto MARK_DATA;
#endif /* CLOS */
      case t_codeblock:
            mark_object(x->cblock.name);
            mark_object(x->cblock.next);
            mark_object(x->cblock.links);
            p = x->cblock.temp_data;
            if (p) {
                  i = x->cblock.temp_data_size;
                  mark_contblock(p, i * sizeof(cl_object));
                  while (i-- > 0)
                        mark_object(p[i]);
            }
            i = x->cblock.data_size;
            p = x->cblock.data;
            goto MARK_DATA;
      case t_foreign:
            if (x->foreign.size)
                  mark_contblock(x->foreign.data, x->foreign.size);
            mark_next(x->foreign.tag);
            break;
      MARK_DATA:
            if (p) {
                  mark_contblock(p, i * sizeof(cl_object));
                  while (i-- > 0)
                        mark_object(p[i]);
            }
            return;
      default:
            if (debug)
                  printf("\ttype = %d\n", type_of(x));
            error("mark botch");
      }
}

static void
mark_stack_conservative(cl_ptr bottom, cl_ptr top)
{
  int p, m;
  cl_object x;
  struct typemanager *tm;
  cl_ptr j;

  if (debug) { printf("Traversing C stack .."); fflush(stdout); }

  /* On machines which align local pointers on multiple of 2 rather
     than 4 we need to mark twice

  if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0);
     */
  for (j = bottom ; j < top ; j+=sizeof(cl_ptr)) {
    cl_ptr aux = *((cl_ptr*)j);
    /* improved Beppe: */
    if (VALID_DATA_ADDRESS(aux) && type_map[p = page(aux)] < (char)t_end) {
      tm = tm_of((cl_type)type_map[p]);
      x = (cl_object)(aux - (aux - pagetochar(p)) % tm->tm_size);
      m = x->d.m;
      if (m != FREE && m != TRUE) {
      if (m) {
        fprintf(stderr,
              "** bad value %d of d.m in gc page %d skipping mark **",
              m, p); fflush(stderr);
      } else
        mark_object(x);
      }
    }}
  if (debug) {printf(". done.\n"); fflush(stdout); }
}

static void
mark_cl_env(struct cl_env_struct *env)
{
      int i;
      cl_object where;
      bds_ptr bdp;
      ecl_frame_ptr frp;
      struct ihs_frame *ihs;

      mark_contblock(env, sizeof(*env));

      mark_object(env->lex_env);

      mark_contblock(env->stack, env->stack_size * sizeof(cl_object));
      mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top);

      if ((bdp = env->bds_org)) {
            mark_contblock(bdp, env->bds_size * sizeof(*bdp));
            for (;  bdp <= env->bds_top;  bdp++) {
                  mark_object(bdp->symbol);
                  mark_object(bdp->value);
            }
      }
      mark_object(env->bindings_hash);

      if ((frp = env->frs_org)) {
            mark_contblock(frp, env->frs_size * sizeof(*frp));
            for (;  frp <= env->frs_top;  frp++) {
                  mark_object(frp->frs_val);
            }
      }

      for (ihs = env->ihs_top; ihs; ihs = ihs->next) {
            mark_object(ihs->function);
            mark_object(ihs->lex_env);
      }

      for (i=0; i<env->nvalues; i++)
            mark_object(env->values[i]);

      mark_object(env->token);

      if (env->c_env) {
            mark_object(env->c_env->variables);
            mark_object(env->c_env->macros);
            mark_object(env->c_env->constants);
      }

      mark_object(env->fmt_aux_stream);

      mark_contblock(env->queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE);
      mark_contblock(env->indent_stack, sizeof(short) * ECL_PPRINT_INDENTATION_STACK_SIZE);

      mark_object(env->big_register[0]);
      mark_object(env->big_register[1]);
      mark_object(env->big_register[2]);

#ifdef ECL_THREADS
/* We should mark the stacks of the threads somehow!!! */
#error "The old garbage collector does not support threads"
#else
# if DOWN_STACK
      mark_stack_conservative((cl_ptr)(&where), (cl_ptr)env->cs_org);
# else
      mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where));
# endif /* DOWN_STACK */
#endif /* THREADS */

#ifdef ECL_FFICALL
      mark_contblock(env->fficall, sizeof(struct ecl_fficall));
      mark_object(((struct ecl_fficall*)env->fficall)->cstring);
#endif
}

static void
mark_phase(void)
{
      int i;
      cl_object s;

      /* save registers on the stack */
      jmp_buf volatile registers;
      ecl_setjmp(registers);

      /* mark registered symbols & keywords */
      for (i=0; i<cl_num_symbols_in_core; i++) {
            s = (cl_object)(cl_symbols + i);
            s->symbol.m = FALSE;
      }
      for (i=0; i<cl_num_symbols_in_core; i++) {
            s = (cl_object)(cl_symbols + i);
            mark_object(s);
      }

      /* We mark everything, but we do not want to get the loaded
       * libraries to be marked unless they are referenced somewhere
       * else (function definition. etc) */
      s = cl_core.libraries;
      if (s) {
            for (i = 0; i < s->vector.fillp; i++) {
                  cl_object dll = s->vector.self.t[i];
                  if (dll->cblock.locked) {
                        mark_object(dll);
                  }
            }
            s->vector.elttype = aet_fix;
            mark_object(s);
            s->vector.elttype = aet_object;
      }
      mark_stack_conservative((cl_ptr)&cl_core, (cl_ptr)(&cl_core + 1));
      /* mark roots */
      for (i = 0; i < gc_roots;  i++)
            mark_object(*gc_root[i]);

#ifdef ECL_THREADS
      mark_object(cl_core.processes);
#else
      mark_cl_env(&cl_env);
#endif
}

static void
sweep_phase(void)
{
      register int i, j, k;
      register cl_object x;
      register cl_ptr p;
      register struct typemanager *tm;
      register cl_object f;

      Cnil->symbol.m = FALSE;
      Ct->symbol.m = FALSE;

      if (debug)
            printf("type map\n");

      for (i = 0;  i < maxpage;  i++) {
            if (type_map[i] == (int)t_contiguous) {
                  if (debug) {
                        printf("-");
                        continue;
                  }
            }
            if (type_map[i] >= (int)t_end)
                  continue;

            tm = tm_of((cl_type)type_map[i]);

      /*
            general sweeper
      */

            if (debug)
                  printf("%c", tm->tm_name[0]);

            p = pagetochar(i);
            f = tm->tm_free;
            k = 0;
            for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
                  x = (cl_object)p;
                  if (x->d.m == FREE)
                        continue;
                  else if (x->d.m) {
                        x->d.m = FALSE;
                        continue;
                  }
                  /* INV: Make sure this is the same as in alloc_2.d */
                  switch (x->d.t) {
#ifdef ENABLE_DLOPEN
                  case t_codeblock:
                        if (x->cblock.links) {
                              cl_mapc(2, @'si::unlink-symbol', x->cblock.links);
                        }
                        ecl_library_close(x);
                        break;
#endif
                  case t_stream:
#if defined(ECL_WSOCK)
                        if (x->stream.mode == smm_input_wsock
                            || x->stream.mode == smm_output_wsock
                            || x->stream.mode == smm_io_wsock) {
                              closesocket((int)x->stream.file);
                        } else
#endif
                        if (x->stream.file != NULL)
                              fclose(x->stream.file);
                        x->stream.file = NULL;
#ifdef ECL_THREADS
                  case t_lock:
#if defined(_MSC_VER) || defined(mingw32)
                        CloseHandle(x->lock.mutex);
#else
                        pthread_mutex_destroy(&x->lock.mutex);
#endif
                        break;
#endif
                  default:;
                  }
                  ((struct freelist *)x)->f_link = f;
                  x->d.m = FREE;
                  f = x;
                  k++;
            }
            tm->tm_free = f;
            tm->tm_nfree += k;
            tm->tm_nused -= k;
      }

      if (debug) {
            putchar('\n');
            fflush(stdout);
      }
}

static void
contblock_sweep_phase(void)
{
      register int i, j;
      register cl_ptr s, e, p, q;
      register struct contblock *cbp;

      cb_pointer = NULL;
      ncb = 0;
      for (i = 0;  i < maxpage;) {
            if (type_map[i] != (int)t_contiguous) {
                  i++;
                  continue;
            }
            for (j = i+1;
                 j < maxpage && type_map[j] == (int)t_contiguous;
                 j++)
                  ;     
            s = pagetochar(i);
            e = pagetochar(j);
            for (p = s;  p < e;) {
                  if (get_mark_bit((int *)p)) {
                        p += 4;
                        continue;
                  }
                  q = p + 4;
                  while (q < e && !get_mark_bit((int *)q))
                        q += 4;
                  cl_dealloc(p, q - p);
                  p = q + 4;
            }
            i = j + 1;
      }

      if (debug) {
            for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link)
                  printf("0x%p %d\n", cbp, cbp->cb_size);
            fflush(stdout);
      }
}

cl_object (*GC_enter_hook)() = NULL;
cl_object (*GC_exit_hook)() = NULL;

void
ecl_gc(cl_type t)
{
      int i, j;
      int tm;
      int gc_start = ecl_runtime();
      bool interrupts;

      if (!GC_enabled())
            return;

      GC_disable();

      CL_NEWENV_BEGIN {
      if (SYM_VAL(@'si::*gc-verbose*') != Cnil) {
            printf("\n[GC ..");
            /* To use this should add entries in tm_table for reloc and contig.
               fprintf(stdout, "\n[GC for %d %s pages ..",
               tm_of(t)->tm_npage,
               tm_table[(int)t].tm_name + 1); */
            fflush(stdout);
      }

      debug = symbol_value(@'si::*gc-message*') != Cnil;

      if (GC_enter_hook != NULL)
            (*GC_enter_hook)();

#ifdef THREADS
#error "We need to stop all other threads"
#endif /* THREADS */

      interrupts = ecl_interrupt_enable;
      ecl_interrupt_enable = 0;

      collect_blocks = t > t_end;
      if (collect_blocks)
            cbgccount++;
      else
            tm_table[(int)t].tm_gccount++;

      if (debug) {
            if (collect_blocks)
                  printf("GC entered for collecting blocks\n");
            else
                  printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name);
            fflush(stdout);
      }

      maxpage = page(heap_end);

      if (collect_blocks) {
            /*
              1 page = 512 word
              512 bit = 16 word
            */
            int mark_table_size = maxpage * (LISP_PAGESIZE / 32);
            extern void cl_resize_hole(cl_index);

            if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1)
                  new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1;
            if (new_holepage < HOLEPAGE)
                  new_holepage = HOLEPAGE;
            cl_resize_hole(new_holepage);

            mark_table = (int*)heap_end;
            for (i = 0;  i < mark_table_size; i++)
                  mark_table[i] = 0;
      }

      if (debug) {
            printf("mark phase\n");
            fflush(stdout);
            tm = ecl_runtime();
      }
      mark_phase();
      if (debug) {
            printf("mark ended (%d)\n", ecl_runtime() - tm);
            printf("sweep phase\n");
            fflush(stdout);
            tm = ecl_runtime();
      }
      sweep_phase();
      if (debug) {
            printf("sweep ended (%d)\n", ecl_runtime() - tm);
            fflush(stdout);
      }

      if (t == t_contiguous) {
            if (debug) {
                  printf("contblock sweep phase\n");
                  fflush(stdout);
                  tm = ecl_runtime();
            }
            contblock_sweep_phase();
            if (debug)
                  printf("contblock sweep ended (%d)\n", ecl_runtime() - tm);
      }

      if (debug) {
            for (i = 0, j = 0;  i < (int)t_end;  i++) {
                  if (tm_table[i].tm_type == (cl_type)i) {
                        printf("%13s: %8d used %8d free %4d/%d pages\n",
                               tm_table[i].tm_name,
                               tm_table[i].tm_nused,
                               tm_table[i].tm_nfree,
                               tm_table[i].tm_npage,
                               tm_table[i].tm_maxpage);
                        j += tm_table[i].tm_npage;
                  } else
                        printf("%13s: linked to %s\n",
                               tm_table[i].tm_name,
                               tm_table[(int)tm_table[i].tm_type].tm_name);
            }
            printf("contblock: %d blocks %d pages\n", ncb, ncbpage);
            printf("hole: %d pages\n", holepage);
            printf("GC ended\n");
            fflush(stdout);
      }

      ecl_interrupt_enable = interrupts;

      if (GC_exit_hook != NULL)
            (*GC_exit_hook)();

      } CL_NEWENV_END;

      GC_enable();

#ifdef THREADS
#error "We need to activate all other threads again"
#endif /* THREADS */

      gc_time += (gc_start = ecl_runtime() - gc_start);

      if (SYM_VAL(@'si::*gc-verbose*') != Cnil) {
            /* Don't use fprintf since on Linux it calls malloc() */
            printf(". finished in %.2f\"]", gc_start/60.0);
            fflush(stdout);
      }

      if (cl_env.interrupt_pending) si_check_pending_interrupts();
      
      end_critical_section();
}

/*
 *----------------------------------------------------------------------
 *
 * mark_contblock --
 *     sets the mark bit for words from address p to address p+s.
 *     Both p and p+s are rounded to word boundaries.
 *
 * Results:
 *    none.
 *
 * Side effects:
 *    mark_table
 *
 *----------------------------------------------------------------------
 */

static void
_mark_contblock(void *x, cl_index s)
{
      cl_ptr p = x;
      if (p >= heap_start && p < data_end) {
            ptrdiff_t pg = page(p);
            if ((cl_type)type_map[pg] == t_contiguous) {
                  cl_ptr q = p + s;
                  p = int2ptr(ptr2int(p) & ~3);
                  q = int2ptr(ptr2int(q + 3) & ~3);
                  for (;  p < q;  p+= 4)
                        set_mark_bit(p);
            }
      }
}

/*----------------------------------------------------------------------
 * Utilities
 *----------------------------------------------------------------------
 */

@(defun si::room_report ()
      int i;
      cl_object *tl;
@
      NVALUES = 8;
      VALUES(0) = MAKE_FIXNUM(real_maxpage);
      VALUES(1) = MAKE_FIXNUM(available_pages());
      VALUES(2) = MAKE_FIXNUM(ncbpage);
      VALUES(3) = MAKE_FIXNUM(maxcbpage);
      VALUES(4) = MAKE_FIXNUM(ncb);
      VALUES(5) = MAKE_FIXNUM(cbgccount);
      VALUES(6) = MAKE_FIXNUM(holepage);
      VALUES(7) = Cnil;
      tl = &VALUES(7);
      for (i = 0;  i < (int)t_end;  i++) {
        if (tm_table[i].tm_type == (cl_type)i) {
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_nused), Cnil));
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_nfree), Cnil));
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_npage), Cnil));
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_maxpage), Cnil));
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_gccount), Cnil));
        } else {
          tl = &CDR(*tl = CONS(Cnil, Cnil));
          tl = &CDR(*tl = CONS(MAKE_FIXNUM(tm_table[i].tm_type), Cnil));
          tl = &CDR(*tl = CONS(Cnil, Cnil));
          tl = &CDR(*tl = CONS(Cnil, Cnil));
          tl = &CDR(*tl = CONS(Cnil, Cnil));
        }
      }
      return VALUES(0);
@)

@(defun si::reset_gc_count ()
      int i;
@
      cbgccount = 0;
      for (i = 0;  i < (int)t_end;  i++)
            tm_table[i].tm_gccount = 0;
      @(return)
@)

@(defun si::gc_time ()
@
      @(return MAKE_FIXNUM(gc_time))
@)

void
init_GC(void)
{
      GC_enable();
      gc_time = 0;
}

Generated by  Doxygen 1.6.0   Back to index