/* Copyright (C) 1989, Digital Equipment Corporation           */
/* All rights reserved.                                        */
/* See the file COPYRIGHT for a full description.              */

/* Last modified on Thu Jun 28 19:36:11 1990 by muller         */

/* This file implements the memory management part of the run-time 
system for Modula-3. Both the TRACED and UNTRACED references are 
processed here. 

The garbage collector for the TRACED references is an adaptation 
of the algorithm presented in the WRL Research Report 88/2, 
``Compacting Garbage Collection with Ambiguous Roots'', by Joel F. 
Bartlett; see this report for a detailled presentation. 

Compared to the algorithm presented at the end of the paper, we should
note the following differences:

  - if we run out of space at any point, we try to get more pages
    from the operating system rather than fail. Of course, is the os
    is not cooperating, we have no choice but to fail.

  - some bugs have been removed. In the original presentation, if
    the heap is made of two pages and there are no external hints
    to the heap, trying to allocate a page causes garbage collection,
    which does nothing, and there is an infinite loop. Actually, the
    garbage collection itself is essentially idempotent, so that the
    while loop in gcalloc is unnessary. Also, the processing of
    multi-pages objects is wrong; when a hint is used to promote a
    page, one should go both ways to promote the adjacent pages that
    are also part of the object.

  - the pointer internal to allocated objects are not supposed to be
    first n words in the object; rather, the compiler generates a
    procedure for each type (that we access through the typecode,
    stored in the header) that applies a routine to each pointer.

  - the contents of the global variables is treated as hint (i.e.
    the pages they point to are promoted rather than moving the objects
    they point too). This is because in Modula-3, we want to treat
    all the variables area as the globals (we have no way to distinguish
    the pointers from the others variables without strong support
    from the compiler).
*/


#include "M3Runtime.h"
#include <stdio.h>
#include "gc.h"

#define PRIVATE static
#define PUBLIC  
#define IMPORT extern
#define FORWARD

IMPORT char *malloc ();
IMPORT char *realloc ();

IMPORT void _M3Runtime__Error ();

int collection_allowed = 1;

FORWARD PUBLIC char * _M3Runtime__NewUntraced ();

PUBLIC void (*_M3Runtime__BeforeGC) ();
PUBLIC void (*_M3Runtime__AfterGC) ();

/*------------------------------------------ LOW-LEVEL MEMORY MANAGMENT ---*/

/* The memory is viewed as a collection of pages. Each page has a
number that identifies it, based on the addresses that are part of
this page: page p contains the addresses p*BYTES_PER_PAGE to
(p-1)*BYTES_PER_PAGE - 1. It is convenient to have BYTES_PER_PAGE to
be a power of two, so as to simplify some computations (gcp2page and
page2gcp). Anyway, pages must be aligned with respect to the alignment
for objects (see below). Page -1 is the invalid page.  */

/* gc.h: typedef int PAGE */

#define WORDS_PER_PAGE /*40*/ 512
#define BYTES_PER_PAGE (WORDS_PER_PAGE * 4)

#define INVALID_PAGE -1


/* The array space and the global variables first_allocated_page and
last_allocated_page indicate which pages are part of the traced heap.
More precisely, no pages are allocated if first_allocated_page or
last_allocated_page is invalid; otherwise, page p is allocated iff

  first_allocated_page <= p <= last_allocated_page and 
    space [p] != UNALLOCATED

The space array is indexed by
[first_allocated_page..last_allocated_page]; if an entry is not
UNALLOCATED, then it is the space in which the page resides.  The
range of space is [-1..x] where x is large enough to ensure that the
freepage index completely sweeps all of memory before a space
identifier is ever resused. */

PRIVATE PAGE first_allocated_page, last_allocated_page;
PRIVATE GCP first_allocated_word, first_non_allocated_word;

PRIVATE int *space;

#define UNALLOCATED -1
#define NEXT_SPACE(s) (((s) + 1) & 077777777)
#define PREVIOUS_SPACE(s) ((s) == 0 ? 077777777 : (s) - 1)

/* Two spaces are of particular importance: next_space, in which we
are allocating, and current_space the one from which we are
collecting. Usually, these two spaces are equal; it is only during
garbage collection that they differ.
*/

PRIVATE int next_space, current_space;

/* We keep the number of allocated pages in a global variable; it
should satify the invariant:

     allocated_pages = sigma (i = first_allocated_page, last_allocated_page,
                              space [i] != UNALLOCATED)

We also keep the number of active pages in a global; it satisfies:

     active_pages = sigma (i = first_allocated_page, last_allocated_page,
                           space [i] == next_space)
*/

PRIVATE int allocated_pages = 0;
PRIVATE int active_pages;

/* If a page is allocated, its type can be OBJECT or CONTINUED. In the
first case, there is an object just at the beginning of the page and
others following. The second case occurs when an objeect was too large
to fit on the rest of a page: it starts somewhere on an OBJECT page
(following some other objects entirely contained on this page) and
overflows on contiguous CONTINUED pages. Whatever space is left on the
last CONTINUED page is never used. In other words, all the headers of
objects are on OBJECT pages; it may happen that the header is the last
word of an OBJECT page and the body of the object (hence the pointer
seen by the application) starts on a CONTINUED page.

The type array is indexed by [first_allocated_page..last_allocated_page].
*/

typedef enum { OBJECT, CONTINUED } page_type;

PRIVATE page_type *type;

/* Every object is made of a reference header, followed by the actual
contents of the object, as seen by the code generated by the compiler.
The header can take one of two forms:
   - it can be typecode of the object
   - it can be a forwarding pointer to the actual location of the object.
     (this occurs during garbage collection only, so that the application
      does not need to know about that detail).

To minimize the amount of storage needed for these two pieces, we use
the following properties: headers (as well as objects) are always
aligned on a word boundary. Thus, the two low order bits of the
forwarding pointers have to the 0. When we want to store a typecode in
the header, we set the lowest bit to 1 and use the remaining bits for
the typecode. Therefore, we have the following declaration for the
typecode version of the header:
*/

/* M3RuntimeDecl.h: 
    typedef int refHeader;
    #define TYPECODE_OF(x) ((*((refHeader *) (x))) >> 1)
    #define SET_TYPECODE(x,y)  (*((refHeader *) (x))) = (y << 1) | 1;
    #define FORWARDING(x)  (((*((refHeader *) (x))) & 1) == 0)
*/

#define HEADER_OF(o) (((refHeader *)(o))- 1)

/* We need to be able to determine the size of an object during
collection; here is a function to do just that. It is called with a
non-nil pointer to a refHeader of a object that is there; that is the
refHeader cannot be a forwarding pointer. */

IMPORT TYPE type_cell ();

PRIVATE int object_size (r)
    refHeader *r;
{  
  TYPE t_cell = type_cell (TYPECODE_OF (r));
  int res;

  if (t_cell->datasize == VARIABLE_SIZE) {
    /* the first word of the object is its size */
    res = *(int *)(r + 1); }

  else if (t_cell->datasize == OPEN_ARRAY) {
    /* the object is an open array; it has the following layout:
           pointer to the elements (char *)
           size 1
           ....
           size n
           elements
           ....
       where n is the number of open dimensions (given by the typecell)
       and each size is the number of elements along the dimension */
    int *sizes = (int *)(((char **) (r + 1)) + 1);
    int size = 1;
    int i;
    for (i = 0; i < t_cell->dimensions; i++, sizes++) {
      size *= *sizes; }
    size *= t_cell->elemSize;
    size += sizeof (char *) + t_cell->dimensions * sizeof (int);
    res = size; }

  else {
    /* the typecell datasize tells the truth */
    res = t_cell->datasize; }

  return (words2bytes (bytes2words (res)));
}


/* To simplify our life, we arrange for the objects to be one next to
the other; thus we do not have to deal with holes. In the same spirit,
we insert fake objects to fill pages when there isn't enough space to
allocate another object on that page. The one_word_filler typecell is
used when the hole to fill is exactly one word; its says that the size
of the object is 0 (plus one word of header). multi_word_filler is
used when the hole is larger, and says the object is of VARIABLE_SIZE;
we just have to be carefull to store the right number at the beginning
of the object. */

IMPORT typecell one_word_filler, multi_word_filler;

/* We have two kinds of alignment problems to take care of.  The first
is the alignment of pointers to the roots in the stacks. STACK_INC
(defined in M3Machine.h) is the amount in bytes by which the pointer
sweeping the stacks to discover pointers to roots have to be advanced.

The second problem is the alignement of the objects. Because we do not
know what the fields and their alignment requirements are, we have to
provide all objects with some given alignment in the style of malloc.
Note that it is the body of the object, not the header, that must be
aligned. Alignment is realized by inserting the proper filler in front
of objects. ALIGNMENT (defined in M3Machine.h) expresses in words the
required alignment. */

/*
Given an allocated page, we often need to find the next allocated one.
*/

PRIVATE PAGE next_page (p)
  PAGE p;
{
  do {
    p++; }
    while ((p <= last_allocated_page) && (space [p] == UNALLOCATED));

  return ((p > last_allocated_page) ? first_allocated_page : p);}

/*
The convention about page numbering allows for a simple conversion
from an address to the number of of the page in which it is, as well
as from a page number to the first address is contains:
*/

PRIVATE gcp2page (p)
     PAGE p;
{
  p = (PAGE) (((int) p) / BYTES_PER_PAGE);

  if ((p < first_allocated_page) || (p > last_allocated_page) ||
      (space [p] == UNALLOCATED)) {
    return (INVALID_PAGE); }
  else {
    return (p); }
}

#define page2gcp(p) ((GCP)  ((p) * BYTES_PER_PAGE))


/* We remember where we should look for free space with the following
globals: */

PRIVATE int free_words;		/* # of free words in the current page */
PRIVATE PAGE free_page;         /* first possible free page */

PRIVATE GCP freep;		/* first free byte in the current */
				/* page, if free_words is non-null */


/* When we detect that a page may contain roots, we insert it
in a global queue. Here we know that the page is allocated, so there
is no need to check that.  This queue is represented by the globals
queue_head and queue_tail (the number of first and last page of the
queue respectively), and by the array 'link
[first_allocated_page..last_allocated_page]'.  */

PRIVATE PAGE queue_head, queue_tail;

PRIVATE PAGE *link;

PRIVATE void queue (p)
    PAGE p; 
{
  if (queue_head != INVALID_PAGE) {
    link [queue_tail] = p; }
  else {
    queue_head = p; }
  link [p] = INVALID_PAGE;
  queue_tail = p;
}


/* To move an object to the new space, modifying the original reference */

PRIVATE void move (cp, root, aux)
    GCP *cp;
    GCP root;
    char *aux;  
{
  PAGE p = gcp2page (*cp);	/* the page on which the object is */
  refHeader *header;		/* the header of the object to be moved */
  int node_size;		/* the size of the object in bytess */
  GCP np;                       /* pointer to new object */


  /* verify that the reference is to something that really
     need to be moved (i.e. in our world, not in the next space) */

  if ((p == INVALID_PAGE) || (space [p] == next_space)) {
    return; }
  
  /* may be it has already been moved ? In which case, we just have
     to update the reference */

  header = HEADER_OF (*cp);
  if (FORWARDING (header)) {
    *cp = *((GCP *) (header+1));
    return; }

  /* ok, let's move it */

  node_size = object_size (header);
  np = gcalloc (node_size, TYPECODE_OF (header));
  bcopy ((GCP) header,
	 (GCP) HEADER_OF (np),
	 sizeof(refHeader) + node_size);

  /* if it is an open array, it has an internal pointer that we should 
     update */
  { TYPE t_cell = type_cell (TYPECODE_OF (header));
    if (t_cell->datasize == OPEN_ARRAY) {
      *(char**)np = (char*)((int*)(((char**) np) + 1) + t_cell->dimensions); }}

  (*header)--;
  *((GCP *) (header+1)) = np;
  *cp = np;
}

/* When an allocated page is referenced by the stack, registers or global
variables, we have to move it to the next space and insert it in the
list of promoted pages. In the case where the page is actually part of
a group of pages for a big object, we have to promote all these pages
to the new space, but only the first one needs to be inserted in the
queue, as it is the only one containing object headers. */

PRIVATE void promote_page (p)
    PAGE p;			/* p is assumed to be allocated */
{
  do { 
    p++; }
    while ((p <= last_allocated_page) && 
           (type [p] == CONTINUED) && (space [p] == current_space));
  p--;
  while (type [p] == CONTINUED) {
    space [p] = next_space;
    active_pages++;
    p--; }
  space [p] = next_space;
  active_pages ++;
  queue (p);
}


/* This routine is passed to the Threads implementation. It is called
for each stack, where start and stop are the first and last word of
the stack under consideration. */

PRIVATE void collectStackLocations (start, stop)
     GCP *start, *stop;
{
  GCP *fp;

  for (fp = start; fp <= stop; 
       fp = (GCP *)(((char *)fp) + STACK_INC)) {
    register GCP p = *fp;
    if ((first_allocated_word <= p) && (p < first_non_allocated_word)) {
      register PAGE pp = (PAGE) (((int) p) / BYTES_PER_PAGE);
      if (space [pp] == current_space) {
	promote_page (pp); }}}
}

/* collect is called to actually garbage collect the traced heap */

PRIVATE void collect ()
{
  GCP *fp;             /* pointer for checking the stack */

  IMPORT _ThreadF__ProcessStacks ();

  if (_M3Runtime__BeforeGC != NULL) {
    _M3Runtime__BeforeGC (); }

  /* No pages have been promoted so far */

  queue_head = INVALID_PAGE;
  queue_tail = INVALID_PAGE;

  /* Examine the stacks for possible pointers */
  _ThreadF__ProcessStacks (collectStackLocations);

  /* Examine the global variables for possible pointers */
  _M3Runtime__GlobalMapProc (move);

  /* Sweep accross promoted pages and move their constituent items */
  while (queue_head != INVALID_PAGE) {
    GCP cp = page2gcp (queue_head);
    while ((gcp2page (cp) == queue_head) &&
	   ((free_words == 0) || (gcp2page (freep) != queue_head) || 
	    (cp < freep))) {
      TYPE tc = type_cell (TYPECODE_OF (cp));
      if (tc->mapProc != NULL) {
	(tc->mapProc) (move, ((refHeader *) cp) + 1, NULL); }
      cp += sizeof (refHeader) + object_size ((refHeader *) cp); }
    queue_head = link [queue_head]; }

  if (_M3Runtime__AfterGC != NULL) {
    _M3Runtime__AfterGC (); }
}


/* When we need more heap, we get it from the operating system. This
function returns the number of the first new page. */

PUBLIC int   _M3Runtime__HeapIncrement = 64;
PUBLIC float _M3Runtime__HeapMult      = .2;

PRIVATE PAGE grow_heap (min_inc)
     int min_inc;		/* minimum number of pages to get */
{
  int first_new_page,
      last_new_page,
      new_first_allocated_page,
      new_last_allocated_page,
      new_heap_span,
      *new_space,
      *new_link,
      i;
  page_type *new_type;
  char *new_chunk;

  min_inc = ((min_inc < _M3Runtime__HeapIncrement) ?
	     _M3Runtime__HeapIncrement : min_inc);
  min_inc = ((min_inc < allocated_pages * _M3Runtime__HeapMult) ?
	     allocated_pages * _M3Runtime__HeapMult : min_inc);

  new_chunk = (char *) malloc ((min_inc + 1) * BYTES_PER_PAGE);
  
  if (new_chunk == NULL) {
    _M3Runtime__Error ("gc: Could not extend the traced heap\n"); }
  
  /* find the pages that are in this new chunk */
  first_new_page = (PAGE) ((((unsigned) new_chunk) + BYTES_PER_PAGE - 1) /
    BYTES_PER_PAGE);
  last_new_page = first_new_page + min_inc - 1;
  
  /* determine the new boundaries of the heap */
  if (allocated_pages == 0) {
    new_first_allocated_page = first_new_page;
    new_last_allocated_page  = last_new_page; }
  else if (first_new_page < first_allocated_page) {
    new_first_allocated_page = first_new_page;
    new_last_allocated_page  = last_allocated_page; }
  else if (last_allocated_page < last_new_page) {
    new_first_allocated_page = first_allocated_page;
    new_last_allocated_page = last_new_page; }
  else {
    new_first_allocated_page = first_allocated_page;
    new_last_allocated_page = last_allocated_page; }
    
  /* allocate the new side arrays */
  new_heap_span = new_last_allocated_page - new_first_allocated_page + 1;
  
  new_space = (int *) malloc (new_heap_span * sizeof (int));
  new_type  = (page_type *) malloc (new_heap_span * sizeof (page_type));
  new_link  = (int *) malloc (new_heap_span * sizeof (int));
  
  if (new_space == NULL || new_type == NULL || new_link == NULL) {
    _M3Runtime__Error ("gc: Could not reallocate the auxilliary storage\n"); }

  /* include the boundary offset */
  new_space -= new_first_allocated_page;
  new_type  -= new_first_allocated_page;
  new_link  -= new_first_allocated_page;

  /* update the new side arrays */
  if (allocated_pages) {
    for (i = first_allocated_page; i <= last_allocated_page; i++) {
      new_space [i] = space [i];
      new_type [i] = type [i];
      new_link [i] = link [i]; }}
  for (i = first_new_page; i <=  last_new_page; i++) {
    new_space [i] = PREVIOUS_SPACE (current_space);
    /* we do not care about the values of the other fields */ }
  if (allocated_pages) {
    for (i = last_new_page + 1; i < first_allocated_page; i++) {
      new_space [i] = UNALLOCATED; }
    for (i = last_allocated_page + 1; i < first_new_page; i++) {
      new_space [i] = UNALLOCATED; }}

  /* install the new side arrays */
  if (allocated_pages) {
    free (space + first_allocated_page); 
    free (type  + first_allocated_page); 
    free (link  + first_allocated_page); }
  
  space = new_space;
  type  = new_type; 
  link  = new_link; 

  /* update the global variables */
  first_allocated_page = new_first_allocated_page;
  last_allocated_page = new_last_allocated_page;

  first_allocated_word = page2gcp (first_allocated_page);
  first_non_allocated_word = page2gcp (last_allocated_page + 1);

  allocated_pages += min_inc;

  return (first_new_page);
}


/* When we try to allocate on a page and that page doesn't have enough
space, we are forced to lose this piece. But to simplify sweeping, we
put a filler.
*/

PRIVATE fill (words) 
     int words;
{
  refHeader *f = (refHeader *) freep;

  if (words > 1) {
    SET_TYPECODE (f, multi_word_filler.typecode);
    *((int *) (f + 1)) = words2bytes (words - 1);
    free_words -= words;
    freep += words * 4; }
  else if (words == 1) {
    SET_TYPECODE (f, one_word_filler.typecode);
    free_words--;
    freep += 4; }
}

IMPORT int _ThreadSup__inCritical;

PUBLIC GCP gcalloc (data_size, code) 
    int data_size, code;
{
  /* data_size is in bytess */

  char *a;
  int size, alignment_and_header;

  
  /* We are busy allocating, and it will be simpler if nobody else
     runs for now */
  _ThreadSup__inCritical++;
  
  /* How many words do we need if we allocate on the current page ?
     freep is not necessarily aligned at that point. local_alignment is the
     number of words between freep and the next alignment boundary
     following freep; this boundary is taken different from freep so that 
     the header is counted in local_alignment. */ 

  alignment_and_header = 
    (((((unsigned) freep) / (4 * ALIGNMENT)) + 1) * ALIGNMENT)
                     - (((unsigned) freep) / 4);

  size = alignment_and_header + bytes2words (data_size);

  if (size > free_words) {
    /* The current free page does not have enough space to accomodate our
       needs. We try to get enough free pages. */

    int nb_pages = words2pages (ALIGNMENT + bytes2words (data_size));
    int nb_pages_found;

    /* If allocating the pages we need would lead to more than half of the 
       available pages to be allocated, we try garbage collection
       first (provided we are not already garbage collecting) */


    if ((active_pages + nb_pages > allocated_pages / 2) &&
        (next_space == current_space) &&
        (allocated_pages != 0)) {
      int previous_active_pages = active_pages;

      if (collection_allowed) {
        /* advance space */
        next_space = NEXT_SPACE (current_space);
        active_pages = 0;
        fill (free_words);
        collect (); 
	current_space = next_space; 
	if ((previous_active_pages - active_pages) 
	    < (_M3Runtime__HeapIncrement / 2)) {
	  grow_heap (0); }}
      else {
	grow_heap (0); }}}

  /* May be there is now enough space in the current free page; 
     we have to recompute our requirement, as the filling for alignment
     may be different now. */
  alignment_and_header = 
    (((((unsigned) freep) / (4 * ALIGNMENT)) + 1) * ALIGNMENT)
                     - (((unsigned) freep) / 4);

  size = alignment_and_header + bytes2words (data_size);

  if (size > free_words) {
    int free,			/* # of contiguous free pages */
        page,			/* # of the page examined */
        nb_pages,		/* # of pages we need */
        to_examine;		/* # of pages in the heap */

    /* We could try to use whatever is left of the current page, but
       that would greatly complexify this routine. So we just fill the rest
       of the page and forget about it. */

    fill (free_words);

    /* No, we really have to find other pages. Since the pages are aligned 
       our size is simpler to compute */
    alignment_and_header = ALIGNMENT;
    size = alignment_and_header + bytes2words (data_size);
    nb_pages = words2pages (size);

    /* `free_page'is the first free page we should look at. The
       name of the game is to find a sequence of `nb_pages' contiguous 
       free pages in the heap, starting there. 

       We keep the following invariant: `page' designates the page we 
       are examining and the pages between `free_page' and `page'
       (not included) are free, contiguous and allocated. */

    for (to_examine = allocated_pages, page = free_page, free = 0;
	 (free < nb_pages) && (to_examine > 0);
	 to_examine--) {

      if (space [page] != current_space && 
	  space [page] != next_space &&
	  space [page] != UNALLOCATED) {
	/* page is free */
	if (page == free_page + free) {
	  /* page is contiguous */
	  free++;
	  page = next_page (page); }
	else {
	  free_page = page;
	  page = next_page (page);
	  free = 1; }}
      else {
	free_page = page = next_page (page);
	free = 0; }}

    if (free != nb_pages) {
      /* No such sequence exist. We allocate a new chunk from the system
         and we know that the first pages there have the appropriate
	 properties */
      free_page = grow_heap (nb_pages); 
      page = next_page (free_page + nb_pages - 1); }

    freep = page2gcp (free_page);
    if (nb_pages == 1) {
      /* the rest of the page is usable */
      free_words = WORDS_PER_PAGE; }
    else {
      free_words = size; }

    active_pages += nb_pages;

    if (current_space != next_space) {
      /* We are compacting right now; at some point, we will have
	 to chase the pointers that are in object we are just moving,
	 so we make sure that this page is in the list */
      queue (free_page); }

    space [free_page] = next_space;
    type  [free_page] = OBJECT;
    while (--nb_pages) {
      space [++free_page] = next_space;
      type  [free_page] = CONTINUED; }
    /* we cannot simply increment free_page, because we may end up
       beyond last_allocated_page; page contains the correct value */
    free_page = page; }

  /* align the object */
  if (alignment_and_header - 1) {
    fill (alignment_and_header - 1); }

  /* really allocate this object */
  free_words -= (size - alignment_and_header + 1);

  a = freep;
  SET_TYPECODE (a, code);
  a += sizeof (refHeader);
  freep = a + (bytes2words (data_size)) * 4 ;

  /* The state is now stable, others can allocate */
  _ThreadSup__inCritical--;

  return (a);
}

/*------------------------------------------ MODULA MEMORY ALLOCATION ---*/


PUBLIC char *_M3Runtime__NewTracedRecord (t)
    TYPE t;
/* Allocate some space for a NEWed record. The block representing the
data is a simple block of size t->datasize bytes. Initialization
of this block is performed by calling t->initProc if non-null. */
{
  char *a = gcalloc (t->datasize, t->typecode);
  
  bzero (a, t->datasize);
  
  if (t->initProc) {
    (* (t->initProc)) (a); }

  return (a);
}

PUBLIC char *_M3Runtime__NewTracedObj (t)
    TYPE t;
/*
Allocates some space for a NEWed object. The block representing the data
is of size t->datasize and starts with a pointer to the
method info, followed by the fields of the object. The method info
is a block make of a pointer to the type cell, a flag indicating if
this method block is the standard one (shared by all the objects if
they do not change the methods), and pointers to the methods.

The setupProc takes care of initializing the default method suite
in the type cell. It is called by link-produced code.

The initProc takes care of setting the methods entry to the default
methods and to initialize the fields. */
{
  char *a = gcalloc (t->datasize, t->typecode);

  bzero (a, t->datasize);

  *((char **) a) = t->defaultMethods;

  while (t != NULL) {
    if (t->initProc) {
      (* (t->initProc)) (a); } 
    t = t->parent; }

  return (a);
}

PUBLIC void _M3Runtime__CloneMethodSuite (o, t)
    int **o;
    TYPE t;
/* As all the objects that use the default method suite share the same
representation of it, we have to clone it before changing the methods
of one object. */
{
  if ((*o)[1] == 0) {
    *o = (int *) _M3Runtime__NewUntraced (t->methodsize);
    bcopy (t->defaultMethods, *o, t->methodsize);
    (*o) [1] = 1; }
}


PUBLIC char * _M3Runtime__NewTracedArray (t, n)
    TYPE t;
    int n;
/* Allocate some space for a NEWed open array. The block representing
the data is a pair of pointers, the first to the elements, the second
to the dimensions. Elements are represented in a contiguous block,
as are the dimensions.

Actually, the parameter n is combined size of these three blocks, in bytes.
They are to be allocated as one big block; the dimensions will follow
the header and are followed by the elements themselves.
*/

{
  char *a = gcalloc (n, t->typecode);

  bzero (a, n);

  if (t->initProc) {
    (* (t->initProc)) (a); }

  return (a);
}

PUBLIC char * _M3Runtime__NewUntraced (n)
    int n;
{
  char *a = malloc (n);
  if (a == NULL) {
    _M3Runtime__Error ("gc: Could not alloc in the untraced heap\n"); }

  bzero (a, n);
  return (a); 
}

PUBLIC char * _M3Runtime__NewUntracedRecord (t)
  TYPE t;
{
  char *a = _M3Runtime__NewUntraced (t->datasize);

  if (t->initProc) {
    (* (t->initProc)) (a); }

  return (a); 
}
  
PUBLIC char * _M3Runtime__NewUntracedArray (t, n)
    TYPE t;
    int n;
/* Allocate some space for a NEWed open array. The block representing
the data is a pair of pointers, the first to the elements, the second
to the dimensions. Elements are represented in a contiguous block,
as are the dimensions.

Actually, the parameter n is combined size of these three blocks, in bytes.
They are to be allocated as one big block; the dimensions will follow
the header and are followed by the elements themselves.
*/

{
  char *a = _M3Runtime__NewUntraced (n);

  if (t->initProc) {
    (* (t->initProc)) (a); }

  return (a);
}

PUBLIC char *_M3Runtime__NewUntracedObject (t)
    TYPE t;
/*
Allocates some space for a NEWed object. The block representing the data
is of size t->datasize and starts with a pointer to the
method info, followed by the fields of the object. The method info
is a block make of a pointer to the type cell, a flag indicating if
this method block is the standard one (shared by all the objects if
they do not change the methods), and pointers to the methods.

The setupProc takes care of initializing the default method suite
in the type cell. It is called by link-produced code.

The initProc takes care of setting the methods entry to the default
methods and to initialize the fields. */
{
  char *a = _M3Runtime__NewUntraced (sizeof (refHeader) + t->datasize);

  SET_TYPECODE (a, t->typecode);
  a += sizeof (refHeader);

  *((char **) a) = t->defaultMethods;

  while (t != NULL) {
    if (t->initProc) {
      (* (t->initProc)) (a); } 
    t = t->parent; }

  return (a);
}


PUBLIC void _M3Runtime__DisposeTracedVar (v)
/* dispose of a traced var is defined to be the same as setting this
   variable to NIL */
{
  v = NULL;
}

PUBLIC void _M3Runtime__DisposeTracedValue (v)
{
   _M3Runtime__Error ("dispose_traced_value: Not yet implemented\n"); 
}

PUBLIC void _M3Runtime__DisposeUntracedVar (v)
    char **v;
{
  free (*v);
  *v = 0;
}

PUBLIC void _M3Runtime__DisposeUntracedValue (v)
{
  _M3Runtime__Error ("dispose_untraced_value: Not yet implemented\n"); 
}


/*------------------------------------------------------ INITIALIZATION ---*/

PUBLIC void init_gc ()
{ 
  int i;

  active_pages = 0;
  free_words = 0;
  if (allocated_pages == 0) {
    space = NULL;
    type =  NULL;
    link =  NULL;
    first_allocated_page = last_allocated_page = INVALID_PAGE;
    first_allocated_word = first_non_allocated_word = 0; }
  else {
    for (i = first_allocated_page; i <= last_allocated_page; i++) {
      space [i] = 1; }
    free_page = first_allocated_page; }
      

  queue_head = queue_tail = INVALID_PAGE;

  current_space = 1;
  next_space = 1;

  _M3Runtime__BeforeGC = NULL;
  _M3Runtime__AfterGC  = NULL;
}

PRIVATE void show_page (page)
     PAGE page;
{
  GCP cp = page2gcp (page);
  int p = gcp2page (cp);

  if (p == INVALID_PAGE) {
    fprintf (stderr, "INVALID_PAGE"); }
  else if (type [p] == CONTINUED) {
    fprintf (stderr, "continuation page"); }
  else {
    while ((gcp2page (cp) == p) &&
	   ((gcp2page (freep) != p) || (cp < freep))) {
      TYPE tc = type_cell (TYPECODE_OF (cp));
      fprintf (stderr, "%6x:  typecode %3d\n", cp, tc->typecode);
      cp += sizeof (refHeader) + object_size ((refHeader *) cp); }}
}

PRIVATE void show_gc (mode)
    int mode;
{
  if (mode >= 0) {
    show_page (mode); }
  else {
    int p;
    fprintf (stderr, "cs = %d, ns = %d, queue_head = %d\n",
	     current_space, next_space, queue_head);
    fprintf (stderr, "alloc = %d, active = %d\n", 
	     allocated_pages, active_pages);
    for (p = first_allocated_page; p <= last_allocated_page; p++) {
      if (space [p] == UNALLOCATED) {
	int pp = p + 1;
	while (space[pp] == UNALLOCATED) {
	  pp++; }
	fprintf (stderr, "--------pages # %3d  to #%3d  ------- UNALLOCATED\n",
		 p, pp-1); 
        p = pp - 1; }
      else {
	fprintf (stderr, "page # %3d  [space %5d, link %5d, type %5d]\n", 
		 p, space[p], link[p], type[p]); 
	if (mode == -2) {
	  show_page (p); }}}}
}