/* Garbage collection */

#include "params.h"
#include "gambit.h"
#include "struct.h"
#include "os.h"
#include "opcodes.h"
#include "run.h"


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


void gc_flip();
void gc_scan_range();


long gc_report; /* index of '##gc-report' variable */


#ifdef DEBUG_GC
SCM_obj scanned_object;
void show_state();
#endif


void gc()
{ char *nb, *nt;     /* new space bottom and top  */
  SCM_obj *fb, *ft;  /* free space bottom and top */
  long cpu_times1[2], cpu_times2[2];

  os_cpu_times( cpu_times1 );

  os_notify_gc_begin( SCM_obj_to_int(pstate->id),
                      (long)(sstate->globals[gc_report].value != (long)SCM_false) );

  if (pstate->heap_old > pstate->heap_bot)
  { pstate->heap_old = pstate->heap_bot;
    nb = pstate->heap_mid;
    nt = pstate->heap_top;
  }
  else
  { pstate->heap_old = pstate->heap_mid;
    nb = pstate->heap_bot;
    nt = pstate->heap_mid;
  }

  gc_flip( (char *)sstate, sstate->const_top, nb, nt, &fb, &ft );

  pstate->heap_lim = ((char *)fb) + pstate->heap_margin + (HEAP_ALLOCATION_FUDGE)*sizeof(SCM_obj);
  pstate->heap_ptr = (char *)ft;

  pstate->closure_lim = (char *)ft;
  pstate->closure_ptr = (char *)ft;

  os_notify_gc_end( SCM_obj_to_int(pstate->id), pstate->heap_mid, pstate->heap_bot, (char *)fb, (char *)ft,
                    (long)(sstate->globals[gc_report].value != (long)SCM_false) );

  os_cpu_times( cpu_times2 );

  pstate->stats_counters[STAT_GC] += (cpu_times2[0] - cpu_times1[0]) +
                                     (cpu_times2[1] - cpu_times1[1]);
}


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


#define gc_scan_closure(ptr,header) \
  gc_scan_range((SCM_obj *)ptr, SCM_closure_slots(header), (long)sizeof(SCM_obj))


void gc_scan_roots()
{ long i, g, n, m;
  char *ptr, *limit;

  /* scan processor local storage (each processor has its own) */

#ifdef DEBUG_GC
  scanned_object = 0;
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING processor local storage]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  gc_scan_range( (SCM_obj *)pstate->processor_storage,
                 (long)(sizeof(pstate->processor_storage) / sizeof(SCM_obj)),
                 (long)sizeof(SCM_obj) );

  /* scan global vars (distribute work among processors) */

#ifdef DEBUG_GC
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING global variables]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  g = SCM_obj_to_int( sstate->globals[GLOBAL_VAR_COUNT].value );
  n = SCM_obj_to_int(pstate->nb_processors);
  m = g/n;
  if (SCM_obj_to_int(pstate->id) < (g%n)) m++;
  gc_scan_range( (SCM_obj *)&sstate->globals[SCM_obj_to_int(pstate->id)].value, m, n*sizeof(struct global_rec) );

  for (i=0; i<m; i++)
    sstate->globals[SCM_obj_to_int(pstate->id)+i*n].jump_adr =
      (long)&sstate->tramps[SCM_obj_to_int(pstate->id)+i*n];

  /* scan stack (each processor has an independent stack) */

#ifdef DEBUG_GC
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING stack]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  gc_scan_range( (SCM_obj *)pstate->stack_ptr,
                 (long)(pstate->ltq_head[-1] - pstate->stack_ptr),
                 (long)sizeof(SCM_obj) );

  /* scan work queue (each processor has its own) */

#ifdef DEBUG_GC 
  if (sstate->debug)
    os_warn( "[%d: SCANNING work queue]\n", SCM_obj_to_int(pstate->id) );
#endif

  gc_scan_range( (SCM_obj *)&pstate->workq_head, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->workq_tail, 1L, (long)sizeof(SCM_obj) );

  /* scan current task (each processor has its own) */

#ifdef DEBUG_GC
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING current task]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  gc_scan_range( (SCM_obj *)&pstate->current_task, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->parent_ret, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->parent_frame, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->current_dyn_env, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->temp_task, 1L, (long)sizeof(SCM_obj) );
  gc_scan_range( (SCM_obj *)&pstate->response, 1L, (long)sizeof(SCM_obj) );

  /* scan constant space (each processor GCs its own copy) */

#ifdef DEBUG_GC
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING constant space (with headers)]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  ptr = sstate->const_bot;
  limit = sstate->const_bptr;

  while (ptr < limit)
  { long len, header = *(long *)ptr;

    ptr += sizeof(long);

    if (SCM_header_procedure(header))
    { len = SCM_procedure_length( header );
#ifdef DEBUG_GC
      scanned_object = (long)ptr - sizeof(SCM_obj) + SCM_type_PROCEDURE;
#endif
      if (SCM_header_closure(header))
        gc_scan_closure(ptr,header);
      else
      { long *p, nb_cst;
        p = (long *)(ptr + len);
        nb_cst = SCM_obj_to_int( *(--p) ) - 1;
        gc_scan_range( (SCM_obj *)(p-nb_cst), nb_cst, (long)sizeof(SCM_obj) );
      }
    }
    else
    { len = SCM_header_length( header );
#ifdef DEBUG_GC
      scanned_object = (long)ptr - sizeof(SCM_obj) + SCM_type_SUBTYPED;
#endif
      if (SCM_subtype_is_ovector(SCM_header_subtype( header )))
        gc_scan_range((SCM_obj *)ptr, SCM_header_slots(header), (long)sizeof(SCM_obj));
    }

    ptr = (char *)SCM_align(ptr+len);
  }

#ifdef DEBUG_GC
  scanned_object = 0;
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING constant space (no headers)]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  gc_scan_range( (SCM_obj *)sstate->const_tptr,
                 (long)((SCM_obj *)sstate->const_top - (SCM_obj *)sstate->const_tptr),
                 (long)sizeof(SCM_obj));
}


/*===========================================================================*/
/*                   Machine independent code follows                        */
/*===========================================================================*/


/*-----------------------------------------------------------------------------
 *
 * Garbage collector for Gambit
 *
 * Note: this garbage collector assumes that objects are represented
 *       as specified in the document "gambit/doc/repr".
 *
 */


/*

Layout of memory during a GC:

(note that the location of old space and new space reverses at every GC)


                           HEAP
Low addresses
                 _________________________
             /  |                         |
            /   |                         |
            |   |                         |
            |   |                         |
            |   |     ACTIVE OBJECTS      |
            |   |                         |
  OLD SPACE |   |           +             |
            |   |                         |
            |   |        GARBAGE          |
            |   |                         |
            |   |                         |
            \   |                         |
             \  |_________________________|
             /  |. . . . . . . . . . . . .|
            /   |. subtyped & procedures .|
            |   |. . .  & weak pairs . . .|
            |   |. .  (with headers) . . .| <---- bot_scan     |
            |   |. . . . . . . . . . . . .|                    |
            |   |_ _ _ _ _ _ _ _ _ _ _ _ _|                    |
            |   |                         | <---- bot_alloc   \|/
            |   |                         |
  NEW SPACE |   |         FREE MEM        |
            |   |                         |
            |   |_ _ _ _ _ _ _ _ _ _ _ _ _|
            |   |. . . . . . . . . . . . .| <---- top_alloc   /|\
            |   |.  pairs & placeholders .| <---- top_scan     |
            |   |. . . (no headers)  . . .|                    |
            \   |. . . . . . . . . . . . .|                    |
             \  |_________________________|                    |

High addresses

*/


long const_bot, const_top;                     /* Limits of constant space   */
SCM_obj *bot_alloc, *top_alloc;                /* Allocation pointers        */
SCM_obj *weak_pairs;                           /* Chain of weak pairs        */


#ifdef DEBUG_GC

void show_state()
{ os_warn( "[%d: ", SCM_obj_to_int(pstate->id) );
  os_warn( "bot_alloc=0x%x, ", (long)bot_alloc );
  os_warn( "top_alloc=0x%x]\n", (long)top_alloc );
}

void show_object( object, from )
SCM_obj object, *from;
{ SCM_obj *adr = (object != 0) ? SCM_object_adr(object) : from-10;
  int i;
  for (i=0; i<20; i++)
  { os_warn( "0x%x = ", (long)(adr+i) );
    os_warn( "0x%x\n", adr[i] );
  }
}

void show_invalid( value, object, from )
SCM_obj value, object, *from;
{ os_warn( "\nGC ERROR: object 0x%x ", (long)object );
  os_warn( "at 0x%x ", (long)from );
  os_warn( "contains invalid value 0x%x\n", (long)value );
  show_object( object, 0L );
  os_quit();
}

int correct_value( value )
SCM_obj value;
{ if ((SCM_type(value)!=SCM_type_FIXNUM)&&(SCM_type(value)!=SCM_type_SPECIAL))
    if ((((long)value) < const_bot) || (((long)value) >= const_top))
    { int i;
      for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
        if ((value >= (long)pstate->ps[i]->heap_bot) &&
            (value <= (long)pstate->ps[i]->heap_top)) return 1;
      return 0;
    }
  return 1;
}

#define CHECK_VALID(value,object,from) { if (!correct_value( value )) show_invalid( value, object, from ); }

#else

#define CHECK_VALID(value,object,from)

#endif


/*-----------------------------------------------------------------------------
 *
 * Scan a range of memory for garbage-collectable objects.  Referenced
 * objects are copied from OLD space to NEW space.
 *
 */


#define FORWARD_NO_HEADER FORWARD(SCM_copied_no_header(slot0),adr[1])
#define FORWARD_HEADER    FORWARD(SCM_copied_header(slot0),slot0)
#define FORWARD_CLOSURE   FORWARD(!SCM_header_closure(slot0),slot0)
#define FORWARD(copied,forw_ptr)                                      \
adr = SCM_object_adr(object);          /* Get address of object    */ \
read_and_lock(adr, slot0);             /* Lock it and get slot 0   */ \
if (copied)                            /* Has it been copied?      */ \
{ *from = forw_ptr;                    /* Update reference         */ \
  CHECK_VALID( forw_ptr, scanned_object, from );                      \
  unlock(adr, slot0);                  /* and unlock object        */ \
}                                                                     \
else


void gc_scan_range( from, count, step )
SCM_obj *from;                   /* Where to start scanning                  */
long count;                      /* Number of objects to scan                */
long step;                       /* Step between objects (in bytes)          */
{ register SCM_obj object;               /* Object being checked             */
  register SCM_obj object_copy;          /* Object after data copied         */
  register SCM_obj *adr;                 /* Pointer to data if mem alloc obj */
  register long slot0;                   /* First slot of that data          */
  register SCM_obj len;                  /* Length of headed object          */
  register SCM_obj *b_alloc = bot_alloc; /* Local copy of bot_alloc          */
  register SCM_obj *t_alloc = top_alloc; /* Local copy of top_alloc          */

  while (count-- > 0)                            /* Scan every object        */
  { object = *from;                              /* Fetch next object        */
Rescan:
    if ((((long)object) <  const_bot) ||         /* Don't process objects    */
        (((long)object) >= const_top))           /* stored in constant space */
    {
#ifdef DEBUG_GC
      if (!correct_value( object ))
      { os_warn( "\nGC ERROR: found invalid value 0x%x ", (long)object );
        os_warn( "at 0x%x while scanning\n", (long)from );
        show_object( 0L, from );
        os_quit();
      }
#endif
      switch SCM_type(object)                    /* Dispatch on type         */
      { case SCM_type_PAIR:
          FORWARD_NO_HEADER
          { CHECK_VALID( adr[1], object, from );
            CHECK_VALID( slot0, object, from );
            *(--t_alloc) = adr[1];               /* Allocate and copy pair   */
            *(--t_alloc) = slot0;
            object_copy = SCM_add_type(t_alloc, SCM_type_PAIR);
            adr[1] = object_copy;                /* Remember where copied    */
            store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
            *from = object_copy;                 /* Update reference         */
            CHECK_VALID( object_copy, scanned_object, from );
          }
          break;

        case SCM_type_PROCEDURE:                 /* Must be closure          */
          FORWARD_CLOSURE
          { object_copy = SCM_add_type(b_alloc, SCM_type_PROCEDURE);
            *(b_alloc++) = slot0;
            store_and_unlock(adr, object_copy);  /* remember where copied    */
            len = SCM_procedure_length(slot0);
            adr++;
            while (len>0)
            { CHECK_VALID( *adr, object, from );
              *(b_alloc++) = *(adr++);
              len -= sizeof(SCM_obj);
            }
            b_alloc = (SCM_obj *)SCM_align(b_alloc);
            *from = object_copy;                 /* update reference         */
            CHECK_VALID( object_copy, scanned_object, from );
          }
          break;

        case SCM_type_SUBTYPED:
          FORWARD_HEADER
          { object_copy = SCM_add_type(b_alloc, SCM_type_SUBTYPED);
            *(b_alloc++) = slot0;
            store_and_unlock(adr, object_copy);  /* remember where copied    */
            len = SCM_header_length(slot0);
            adr++;
#ifdef DEBUG_GC
            if (SCM_subtype_is_ovector(SCM_header_subtype( slot0 )))
              while (len>0)
              { CHECK_VALID( *adr, object, from );
                *(b_alloc++) = *(adr++);
                len -= sizeof(SCM_obj);
              }
            else
#endif
              while (len>0)
              { *(b_alloc++) = *(adr++); len -= sizeof(SCM_obj); }
            b_alloc = (SCM_obj *)SCM_align(b_alloc);
            *from = object_copy;                 /* update reference         */
            CHECK_VALID( object_copy, scanned_object, from );
          }
          break;

        case SCM_type_PLACEHOLDER:
          /* Assumption: slot 0 is the value slot, and is itself
             if not yet determined */
          FORWARD_NO_HEADER
          { if (slot0 != object)                 /* Determined?              */
            { unlock(adr, slot0);                /* Unlock & restore value   */
              object = slot0;                    /* Rescan value             */
              *from = object;                    /* Replace P.H. by value    */
              CHECK_VALID( object, scanned_object, from );
              goto Rescan;
            }
            CHECK_VALID( adr[3], object, from );
            CHECK_VALID( adr[2], object, from );
            CHECK_VALID( adr[1], object, from );
            CHECK_VALID( slot0, object, from );
            *(--t_alloc) = adr[3];
            *(--t_alloc) = adr[2];
            *(--t_alloc) = adr[1];
            *(--t_alloc) = slot0;
            object_copy = SCM_add_type(t_alloc, SCM_type_PLACEHOLDER);
            adr[1] = object_copy;                /* Remember where copied    */
            store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
            *from = object_copy;                 /* Update reference         */
            CHECK_VALID( object_copy, scanned_object, from );
          }
          break;

        case SCM_type_WEAK_PAIR:
          FORWARD_NO_HEADER
          { CHECK_VALID( adr[1], object, from );
            CHECK_VALID( slot0, object, from );
            *(b_alloc++) = SCM_make_header(3*sizeof(SCM_obj),SCM_subtype_WEAK_PAIR);
            *(b_alloc++) = (SCM_obj)weak_pairs;
            weak_pairs = b_alloc;
            object_copy = SCM_add_type(b_alloc, SCM_type_WEAK_PAIR);
            *(b_alloc++) = slot0;                /* Allocate and copy pair   */
            *(b_alloc++) = adr[1];
            adr[1] = object_copy;                /* Remember where copied    */
            store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
            *from = object_copy;                 /* Update reference         */
            CHECK_VALID( object_copy, scanned_object, from );
          }
          break;

        case SCM_type_FIXNUM:
        case SCM_type_SPECIAL: break;

        default:
          os_warn( "\nGC ERROR: Bad type code, object=0x%x", (long)object );
#ifdef DEBUG_GC
          if (scanned_object != 0) os_warn( " in 0x%x", scanned_object );
#endif
          os_warn( " at 0x%x\n", (long)from );
#ifdef DEBUG_GC
          show_object( scanned_object, from );
#endif
          os_quit();
      }
    }
    from = (SCM_obj *)(((char *)from) + step);  /* Move to next object       */
  }

  bot_alloc = b_alloc;                          /* Put copies back           */
  top_alloc = t_alloc;
}


/*-----------------------------------------------------------------------------
 *
 * Main procedure of the garbage collector.
 *
 */

void gc_flip( const_b, const_t, new_b, new_t, free_b, free_t )
char *const_b, *const_t;                /* Location of constant space        */
char *new_b, *new_t;                    /* Location of new space             */
SCM_obj **free_b, **free_t;             /* Location of free space after GC   */
{ SCM_obj *top_scan, *bot_scan;         /* Pointers to scan copied data      */

  const_bot  = (long)const_b;
  const_top  = (long)const_t;

  bot_alloc = (SCM_obj *)new_b;
  top_alloc = (SCM_obj *)new_t;

  bot_scan  = bot_alloc;
  top_scan  = top_alloc;

  weak_pairs = NULL;

#ifdef DEBUG_GC
  if (sstate->debug)
  { os_warn( "[%d: ", SCM_obj_to_int(pstate->id) );
    os_warn( "constant space = 0x%x..", (long)sstate->const_bot );
    os_warn( "0x%x ", (long)sstate->const_bptr );
    os_warn( "0x%x..", (long)sstate->const_tptr );
   os_warn( "0x%x]\n", (long)sstate->const_top );
  }
#endif

  gc_scan_roots();                      /* Call gc_scan_range on each root   */

  /* Scan both allocation areas and copy the objects referenced */

Scan:

#ifdef DEBUG_GC
  scanned_object  = 0;
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING heap (no headers)]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  { long count = top_scan - top_alloc;  /* Scan objects without headers      */
    gc_scan_range(top_alloc, count, (long)sizeof(SCM_obj));
    top_scan -= count;
  }

#ifdef DEBUG_GC
  if (sstate->debug)
  { show_state();
    os_warn( "[%d: SCANNING heap (with headers)]\n", SCM_obj_to_int(pstate->id) );
  }
#endif

  while (bot_scan != bot_alloc)         /* Scan objects with headers         */
  { long len, header = (long) *(bot_scan++);

    if (SCM_header_procedure(header))
    { len = SCM_procedure_length( header );
#ifdef DEBUG_GC
      scanned_object = (long)bot_scan - sizeof(SCM_obj) + SCM_type_PROCEDURE;
#endif
      if (SCM_header_closure(header))
        gc_scan_closure(bot_scan,header);
    }
    else
    { len = SCM_header_length( header );
#ifdef DEBUG_GC
      scanned_object = (long)bot_scan - sizeof(SCM_obj) + SCM_type_SUBTYPED;
#endif
      if (SCM_subtype_is_ovector(SCM_header_subtype( header )))
        gc_scan_range(bot_scan, SCM_header_slots(header), (long)sizeof(SCM_obj));
      else if (SCM_header_subtype( header ) == SCM_subtype_WEAK_PAIR)
        gc_scan_range(bot_scan+1, 1L, (long)sizeof(SCM_obj));  /* scan CDR only */
    }

    bot_scan = (SCM_obj *)SCM_align(((char *)bot_scan) + len);
  }

  if (top_scan != top_alloc) goto Scan; /* Scan newly copied objects         */

  *free_b = bot_alloc;
  *free_t = top_alloc;

  barrier( "GC1" );

  /* Update all weak pairs */

  while (weak_pairs != NULL)
  { SCM_obj car = weak_pairs[1];
    SCM_obj *adr;
    switch SCM_type(car)
    { case SCM_type_PAIR:
      case SCM_type_WEAK_PAIR:
      case SCM_type_PLACEHOLDER:
        adr = SCM_object_adr(car);
        car = adr[0];
        if (SCM_copied_no_header(car)) car = adr[1]; else car = SCM_false;
        break;
      case SCM_type_PROCEDURE:
        adr = SCM_object_adr(car);
        car = adr[0];
        if (SCM_header_closure(car)) car = SCM_false;
        break;
      case SCM_type_SUBTYPED:
        adr = SCM_object_adr(car);
        car = adr[0];
        if (!SCM_copied_header(car)) car = SCM_false;
        break;
      case SCM_type_FIXNUM:
      case SCM_type_SPECIAL:
        break;
      default:
        os_warn( "\nGC ERROR: Bad type code for CAR of WEAK_PAIR, CAR=0x%x", (long)car );
        os_warn( " at 0x%x\n", (long)weak_pairs );
        os_quit();
    }
    weak_pairs[1] = car;
    weak_pairs = (SCM_obj *)weak_pairs[-1];
  }

#ifdef DEBUG_GC
  if (sstate->debug)
    show_state();
#endif

  barrier( "GC2" );
}


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