/* -*-C-*-

$Id: wabbit.c,v 1.13 2007/01/05 21:19:25 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

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

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

*/

/* 
 *
 * What's opera, doc?!
 * This file contains the wabbit-hunting garbage collector,
 * by Ziggy and GJR.
 *
 */

#include "scheme.h"
#include "gccode.h"

extern SCHEME_OBJECT Weak_Chain;

extern SCHEME_OBJECT *
  EXFUN (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **));

extern void
  EXFUN (wabbit_season, (SCHEME_OBJECT));

extern void
  EXFUN (duck_season, (SCHEME_OBJECT));

extern void
  EXFUN (fix_weak_chain_and_hunt_wabbits, (void));

/* Wabbit hunting code */
/* Be wary, wary, quiet... */

#define TC_HEADLESS_REFERENCE		TC_NULL
#define TC_REFERENCE_TO_STACK		TC_STACK_ENVIRONMENT
#define TC_REFERENCE_TO_CONSTANT_SPACE	TC_CHARACTER

Boolean
  wabbit_holes_discarded_p,
  wabbit_holes_overwritten_p,
  wabbit_all_dead_p;  

SCHEME_OBJECT
  * wabbit_holes,
  * wabbit_holes_hi,
  * wabbit_lo_address,
  * wabbit_hi_address,
  * wabbit_of_Seville,
  * wabbit_buffer_lo,
  * wabbit_buffer_ptr,
  * wabbit_buffer_hi,
  * old_wabbit_buffer,
  * old_wabbit_buffer_end,
  * hares_lo,
  * hares_hi;

#define ELMER_FUDGE_FACTOR	 4	/* Size of QUAD */
#define ELMER_HUNG_FACTOR	20	/* 1 / (Sales tax in MA in 1994) */
#define RAJIV_SURATI_FACTOR     -20     /* -1 * ELMER_HUNG_FACTOR */

void EXFUN (kill_da_wabbit, (SCHEME_OBJECT *, SCHEME_OBJECT));
Boolean EXFUN (discard_wabbit_holes_p, (SCHEME_OBJECT *, SCHEME_OBJECT *));

/* We need not check wabbit_lo_address by construction:
   wabbit_lo_address is Free at the beginning of the GC, and
   all forwarded objects will point above that, except for
   the wabbit of Seville, a.k.a. the wabbit vector.
 */

#define WABBIT_P(addr)							\
  (((addr) < wabbit_hi_address)						\
   && ((addr) != wabbit_of_Seville))

#define HARE_P(addr)							\
  (((OBJECT_TYPE (* addr)) == TC_BROKEN_HEART)				\
   && ((OBJECT_ADDRESS (* addr)) >= old_wabbit_buffer)			\
   && ((OBJECT_ADDRESS (* addr)) < old_wabbit_buffer_end))

#define RECORD_WABBIT_HOLE(tag, address) do				\
{									\
  if ((wabbit_holes > (new_space_free + ELMER_FUDGE_FACTOR))		\
      || (discard_wabbit_holes_p (scan, new_space_free)))		\
    *--wabbit_holes = (MAKE_POINTER_OBJECT (tag, address));		\
} while (0)

#define KILL_DA_WABBIT(where, last_object) do				\
{									\
  if ((wabbit_buffer_ptr + 2) <= wabbit_buffer_hi)			\
    kill_da_wabbit (where, last_object);					\
  else									\
    wabbit_all_dead_p = false;						\
} while (0)

/* Oh, what have I done!  I've killed the little bunny wabbit... */

#define COPY_CELL()							\
{									\
  *new_space_free++ = *old_space_addr;					\
}

#define COPY_PAIR()							\
{									\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr;					\
}

#define COPY_TRIPLE()							\
{									\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr;					\
}

#define COPY_QUADRUPLE()						\
{									\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr++;				\
  *new_space_free++ = *old_space_addr;					\
}

#define COPY_VECTOR()							\
{									\
  long veclen = (1 + (OBJECT_DATUM (* old_space_addr)));		\
  SCHEME_OBJECT * vecend = (new_space_free + veclen);			\
									\
  if (vecend > wabbit_holes)						\
    discard_wabbit_holes_p (scan, new_space_free);			\
  while (new_space_free != vecend)					\
    *new_space_free++ = *old_space_addr++;				\
}

#define COPY_WEAK_PAIR()						\
{									\
  long car_tag = (OBJECT_TYPE (* old_space_addr));			\
  (*new_space_free++)							\
    = (OBJECT_NEW_TYPE (TC_NULL, (* old_space_addr)));			\
  *new_space_free++ = *++old_space_addr;				\
  * old_space_addr = (OBJECT_NEW_TYPE (car_tag, Weak_Chain));		\
  Weak_Chain = this_object;						\
}

#define RELOCATE_NORMAL_SETUP()						\
{									\
  old_space_addr = (OBJECT_ADDRESS (this_object));			\
  if (old_space_addr < low_heap)					\
  {									\
    if (HARE_P (old_space_addr))					\
      KILL_DA_WABBIT (scan, SHARP_F);					\
    continue;								\
  }									\
  if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)		\
  {									\
    new_space_addr = (OBJECT_ADDRESS (* old_space_addr));		\
    if (WABBIT_P (new_space_addr))					\
      KILL_DA_WABBIT (scan, SHARP_F);					\
    * scan = (MAKE_OBJECT_FROM_OBJECTS (this_object,			\
					(* old_space_addr)));		\
    continue;								\
  }									\
}

#define RELOCATE_NORMAL_END()						\
{									\
  (* (OBJECT_ADDRESS (this_object)))					\
    = (MAKE_BROKEN_HEART (new_space_addr));				\
  (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)),		\
				   new_space_addr));			\
  continue;								\
}

#define RELOCATE_NORMAL_POINTER(copy_code)				\
{									\
  RELOCATE_NORMAL_SETUP ();						\
  new_space_addr = new_space_free;					\
  copy_code;								\
  RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr);	\
  RELOCATE_NORMAL_END ();						\
}

#define RELOCATE_ALIGNED_POINTER(copy_code)				\
{									\
  RELOCATE_NORMAL_SETUP ();						\
  ALIGN_FLOAT (new_space_free);						\
  new_space_addr = new_space_free;					\
  copy_code;								\
  RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr);	\
  RELOCATE_NORMAL_END ();						\
}

#define RELOCATE_RAW_POINTER(tag, copy_code, last_object)		\
{									\
  old_space_addr = ((SCHEME_OBJECT *) this_object);			\
  if (old_space_addr < low_heap)					\
  {									\
    if (HARE_P (old_space_addr))					\
      KILL_DA_WABBIT (scan, last_object);				\
    continue;								\
  }									\
  if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)		\
  {									\
    new_space_addr = (OBJECT_ADDRESS (* old_space_addr));		\
    if (WABBIT_P (new_space_addr))					\
      KILL_DA_WABBIT (scan, last_object);				\
    * scan = ((SCHEME_OBJECT) new_space_addr);				\
    continue;								\
  }									\
  {									\
    SCHEME_OBJECT * saved_old_addr = old_space_addr;			\
									\
    new_space_addr = new_space_free;					\
    copy_code;								\
    RECORD_WABBIT_HOLE (tag, new_space_addr);				\
    (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr));		\
    (* scan) = ((SCHEME_OBJECT) new_space_addr);			\
    continue;								\
  }									\
}

#define RELOCATE_COMPILED_ENTRY(last_object)				\
{									\
  Get_Compiled_Block (old_space_addr,					\
		      ((SCHEME_OBJECT *) this_entry));			\
  if (old_space_addr < low_heap)					\
  {									\
    if (HARE_P (old_space_addr))					\
      KILL_DA_WABBIT (scan, last_object);				\
    new_entry = this_entry;						\
  }									\
  else if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)		\
  {									\
    new_space_addr = (OBJECT_ADDRESS (* old_space_addr));		\
    if (WABBIT_P (new_space_addr))					\
      KILL_DA_WABBIT (scan, last_object);				\
    new_entry =								\
      ((SCHEME_OBJECT)							\
       (RELOCATE_COMPILED_INTERNAL (this_entry,				\
				    new_space_addr,			\
				    old_space_addr)));			\
  }									\
  else									\
  {									\
    SCHEME_OBJECT * saved_old_addr = old_space_addr;			\
									\
    ALIGN_FLOAT (new_space_free);					\
    new_space_addr = new_space_free;					\
    new_entry =								\
      ((SCHEME_OBJECT)							\
       (RELOCATE_COMPILED_INTERNAL (this_entry,				\
				    new_space_addr,			\
				    old_space_addr)));			\
    COPY_VECTOR ();							\
    RECORD_WABBIT_HOLE (TC_COMPILED_CODE_BLOCK, new_space_addr);	\
    (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr));		\
  }									\
}

SCHEME_OBJECT *
DEFUN (wabbit_hunting_gcloop, (scan, new_space_free_loc),
       fast SCHEME_OBJECT * scan
       AND SCHEME_OBJECT ** new_space_free_loc)
{
  long last_nmv_length;
  fast SCHEME_OBJECT
    * new_space_free, * old_space_addr, this_object,
    * low_heap, * new_space_addr, this_entry, new_entry;
  SCHEME_OBJECT
    last_object, * last_object_end, * last_nmv, * last_hare, last_hare_head,
    magic_cookie, saved_cookie, * saved_addr;

  last_object = SHARP_F;
  last_object_end = 0;
  last_nmv = (scan - 2);	/* Make comparison fail until */
  last_nmv_length = 0;		/* an NMV is found. */
  last_hare = (scan - 2);	/* Same here */
  last_hare_head = SHARP_F;
  magic_cookie = SHARP_F;
  saved_cookie = SHARP_F;
  saved_addr = 0;
  new_space_free = * new_space_free_loc;
  low_heap = Constant_Top;
  for ( ; scan != new_space_free; scan++)
  {
    this_object = * scan;

repeat_dispatch:
    Switch_by_GC_Type (this_object)
    {
      case TC_BROKEN_HEART:
        old_space_addr = (OBJECT_ADDRESS (this_object));
        if (scan == old_space_addr)
	{
	  if (this_object == magic_cookie)
	  {
	    magic_cookie = SHARP_F;
	    last_hare = (scan - 1);
	    last_hare_head = scan[-1];
	    saved_addr[0] = scan[-1];
	    scan[-1] = (MAKE_BROKEN_HEART (saved_addr));
	    *scan = saved_cookie;
	    this_object = saved_cookie;
	    goto repeat_dispatch;
	  }
	  else
	  {
	    * new_space_free_loc = new_space_free;
	    return (scan);
	  }
	}
	else if ((old_space_addr < old_wabbit_buffer)
		 || (old_space_addr >= old_wabbit_buffer_end))
	{
	  sprintf (gc_death_message_buffer,
		   "wabbit_hunting_gcloop: broken heart (0x%lx) in scan",
		   this_object);
	  gc_death (TERM_BROKEN_HEART, gc_death_message_buffer,
		    scan, new_space_free);
	  /*NOTREACHED*/
	}
	else
        {
	  SCHEME_OBJECT old_head = old_space_addr[0];

	  switch (GC_Type_Map [(OBJECT_TYPE (old_head))])
	  {
	    default:
	    case GC_Non_Pointer:
	      last_hare = scan;
	      last_hare_head = old_head;
	      break;

	    case GC_Special:
	      if (((OBJECT_TYPE (old_head)) != TC_REFERENCE_TRAP)
		  || ((OBJECT_DATUM (old_head)) <= TRAP_MAX_IMMEDIATE))
	      {
		this_object = old_head;
		last_hare = scan;
		last_hare_head = old_head;
		goto repeat_dispatch;
	      }
	      /* fall through */

	    case GC_Cell:
	    case GC_Pair:
	    case GC_Triple:
	    case GC_Quadruple:
	    case GC_Vector:
	      if ((OBJECT_ADDRESS (old_head)) == scan)
	      {
		last_hare = scan;
		last_hare_head = old_head;
		KILL_DA_WABBIT (scan, old_head);
		break;
	      }
	      /* fall through */

	    case GC_Compiled:
	      saved_addr = old_space_addr;
	      saved_cookie = scan[1];
	      magic_cookie = (MAKE_BROKEN_HEART (scan + 1));
	      scan[1] = magic_cookie;
	      this_object = old_head;
	      *scan = old_head;
	      goto repeat_dispatch;
	  }
	}
	break;

      case TC_MANIFEST_NM_VECTOR:
      case TC_MANIFEST_SPECIAL_NM_VECTOR:
	if ((last_nmv + (1 + last_nmv_length)) == scan)
	  last_object = SHARP_F;
	else if ((OBJECT_TYPE (scan[-1])) == TC_MANIFEST_VECTOR)
	{
	  last_object
	    = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
	  last_object_end = (scan + (OBJECT_DATUM (scan [-1])));
	}
	else if (((scan - 1) == last_hare)
		 && ((OBJECT_TYPE (last_hare_head)) == TC_MANIFEST_VECTOR))
	{
	  last_object
	    = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
	  last_object_end = (scan + (OBJECT_DATUM (last_hare_head)));
	}
	else
	  last_object = SHARP_F;

	last_nmv = scan;
	last_nmv_length = (OBJECT_DATUM (this_object));
	scan += last_nmv_length;
	break;

      /* Compiled code relocation. */

      case TC_LINKAGE_SECTION:
      {
	SCHEME_OBJECT saved_last_object, * saved_last_object_end;

	saved_last_object = last_object;
	saved_last_object_end = last_object_end;
	if ((last_object == SHARP_F) || (last_object_end < scan))
	{
	  last_object = (MAKE_POINTER_OBJECT (TC_HEADLESS_REFERENCE, scan));
	  last_object_end
	    = (scan + (1 + (READ_CACHE_LINKAGE_COUNT (this_object))));
	}

	switch (READ_LINKAGE_KIND (this_object))
	{
	  case REFERENCE_LINKAGE_KIND:
	  case ASSIGNMENT_LINKAGE_KIND:
	  {
	    /* Assumes that all others are objects of type TC_QUAD without
	       their type codes.
	       */

	    fast long count;

	    scan++;
	    for (count = (READ_CACHE_LINKAGE_COUNT (this_object));
		 --count >= 0;
		 scan += 1)
	    {
	      this_object = (* scan);
	      RELOCATE_RAW_POINTER (TC_QUAD, COPY_QUADRUPLE (), last_object);
	    }
	    scan -= 1;
	    break;
	  }

	  case OPERATOR_LINKAGE_KIND:
	  case GLOBAL_OPERATOR_LINKAGE_KIND:
	  {
	    fast long count;
	    fast char * word_ptr;
	    SCHEME_OBJECT * end_scan;

	    START_OPERATOR_RELOCATION (scan);
	    count = (READ_OPERATOR_LINKAGE_COUNT (this_object));
	    word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
	    end_scan = (END_OPERATOR_LINKAGE_AREA (scan, count));

	    while (--count >= 0)
	    {
	      scan = ((SCHEME_OBJECT *) word_ptr);
	      word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
	      EXTRACT_OPERATOR_LINKAGE_ADDRESS (this_entry, scan);
	      RELOCATE_COMPILED_ENTRY (last_object);
	      STORE_OPERATOR_LINKAGE_ADDRESS (new_entry, scan);
	    }
	    scan = end_scan;
	    END_OPERATOR_RELOCATION (scan);
	    break;
	  }

	  case CLOSURE_PATTERN_LINKAGE_KIND:
	    scan += (READ_CACHE_LINKAGE_COUNT (this_object));
	    break;

	  default:
	  {
	    gc_death (TERM_EXIT,
		      "GC: Unknown compiler linkage kind.",
		      scan, Free);
	    /*NOTREACHED*/
	  }
	}
	last_object = saved_last_object;
	last_object_end = saved_last_object_end;
	break;
      }

      case TC_MANIFEST_CLOSURE:
      {
	fast long count;
	fast char * word_ptr;
	SCHEME_OBJECT * area_end;
	SCHEME_OBJECT saved_last_object, * saved_last_object_end;

	saved_last_object = last_object;
	saved_last_object_end = last_object_end;
	if ((last_object == SHARP_F) || (last_object_end < scan))
	{
	  last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, scan));
	  last_object_end = (scan + (1 + (OBJECT_DATUM (this_object))));
	}
	START_CLOSURE_RELOCATION (scan);
	scan += 1;
	count = (MANIFEST_CLOSURE_COUNT (scan));
	word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
	area_end = ((MANIFEST_CLOSURE_END (scan, count)) - 1);

	while ((--count) >= 0)
	{
	  scan = ((SCHEME_OBJECT *) (word_ptr));
	  word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
	  EXTRACT_CLOSURE_ENTRY_ADDRESS (this_entry, scan);
	  RELOCATE_COMPILED_ENTRY (last_object);
	  STORE_CLOSURE_ENTRY_ADDRESS (new_entry, scan);
	}

	scan = area_end;
	END_CLOSURE_RELOCATION (scan);
	last_object = saved_last_object;
	last_object_end = saved_last_object_end;
	break;
      }

      case_compiled_entry_point:
      {
	this_entry = ((SCHEME_OBJECT) (OBJECT_ADDRESS (this_object)));
	RELOCATE_COMPILED_ENTRY (SHARP_F);
	(* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)),
					 ((SCHEME_OBJECT *) new_entry)));
	continue;
      }

      case_Cell:
	RELOCATE_NORMAL_POINTER (COPY_CELL ());
	break;

      case TC_REFERENCE_TRAP:
	if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
	{
	  /* It is a non pointer. */
	  break;
	}
	/* Fall Through. */

      case_Pair:
	RELOCATE_NORMAL_POINTER (COPY_PAIR ());
	break;

      case TC_VARIABLE:
      case_Triple:
	RELOCATE_NORMAL_POINTER (COPY_TRIPLE ());
	break;

      case_Quadruple:
	RELOCATE_NORMAL_POINTER (COPY_QUADRUPLE ());
	break;

      case_Aligned_Vector:
	RELOCATE_ALIGNED_POINTER (COPY_VECTOR ());
	break;

      case TC_FUTURE:
	if (Future_Spliceable (this_object))
	{
	  * scan = (Future_Value (this_object));
	  scan -= 1;
	  continue;
	}
	/* fall through */

      case_Vector:
	RELOCATE_NORMAL_POINTER (COPY_VECTOR ());
	break;

      case TC_WEAK_CONS:
	RELOCATE_NORMAL_POINTER (COPY_WEAK_PAIR ());
	break;

      default:
	sprintf (gc_death_message_buffer,
		 "wabbit_hunting_gcloop: bad type code (0x%02x)",
		 ((unsigned int) (OBJECT_TYPE (this_object))));
	gc_death (TERM_INVALID_TYPE_CODE,
		  gc_death_message_buffer,
		  scan, new_space_free);
	/*NOTREACHED*/

      case_Non_Pointer:
	break;

      }	/* Switch_by_GC_Type */
  } /* For loop */

  * new_space_free_loc = new_space_free;
  return (new_space_free);

} /* wabbit_hunting_gcloop */

void
DEFUN (wabbit_season, (wabbit_descriptor),
       SCHEME_OBJECT wabbit_descriptor)
{
  long n_wabbits, buf_len, ctr;
  SCHEME_OBJECT
    * result, * area, * saved_area,
    wabbit_buffer, wabbit_vector, * wabbit_vector_ptr;

  wabbit_vector = (VECTOR_REF (wabbit_descriptor, 1));
  wabbit_buffer = (VECTOR_REF (wabbit_descriptor, 2));
    
  buf_len = (VECTOR_LENGTH (wabbit_buffer));
  n_wabbits = (VECTOR_LENGTH (wabbit_vector));

  wabbit_all_dead_p = true;
  wabbit_holes_overwritten_p = false;
  wabbit_holes_discarded_p = false;
  wabbit_holes_hi = Heap_Top;
  wabbit_holes = wabbit_holes_hi;

  saved_area = area = Free;
  wabbit_lo_address = saved_area;
  wabbit_hi_address = saved_area;
  wabbit_of_Seville = saved_area;

  wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 0));
  for (ctr = n_wabbits; ctr >= 0; ctr -= 1)
    *area++ = *wabbit_vector_ptr++;

  MEMORY_SET (wabbit_vector, 0, (MAKE_BROKEN_HEART (saved_area)));
  *area = (MAKE_BROKEN_HEART (area));
  Free = (area + 1);
  
  result = (wabbit_hunting_gcloop (saved_area, &Free));
  if (result != area)
  {
    outf_fatal ("\nwabbit_hunt Wabbit scan ended too early.\n");
    Microcode_Termination (TERM_BROKEN_HEART);
  }

  *area = SHARP_F;		/* Remove broken heart on Valentine's day */
  wabbit_lo_address = (area + 1);
  wabbit_hi_address = Free;

  if (BROKEN_HEART_P (MEMORY_REF (wabbit_buffer, 0)))
    /* One of the wabbits is the wabbit buffer itself! */
    wabbit_buffer_lo = (OBJECT_ADDRESS (MEMORY_REF (wabbit_buffer, 0)));
  else
  {
    wabbit_buffer_lo = Free;
    MEMORY_SET (wabbit_buffer, 0, (MAKE_BROKEN_HEART (wabbit_buffer_lo)));
    Free += (1 + buf_len);
  }
  wabbit_buffer_hi = (wabbit_buffer_lo + (1 + buf_len));
  * wabbit_buffer_lo = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, buf_len));
  wabbit_buffer_ptr = (wabbit_buffer_lo + 3);

  /* Check whether any wabbits are hares, and if so, mark them so. */

  old_wabbit_buffer = ((OBJECT_ADDRESS (wabbit_buffer)) + 3);
  old_wabbit_buffer[-1] = (MAKE_BROKEN_HEART (old_wabbit_buffer - 1));

  wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 1));
  
  for (area = old_wabbit_buffer, ctr = n_wabbits; --ctr >= 0; )
  {
    SCHEME_OBJECT wabbit = *wabbit_vector_ptr++;
    SCHEME_OBJECT old_head;

    switch (GC_Type_Map [(OBJECT_TYPE (wabbit))])
    {
      case GC_Non_Pointer:
        /* Sucker -- should crash his scheme */
        break;

      case GC_Special:
	if (((OBJECT_TYPE (wabbit)) != TC_REFERENCE_TRAP)
	    || ((OBJECT_DATUM (wabbit)) <= TRAP_MAX_IMMEDIATE))
	  break;
	/* fall through */

      case GC_Cell:
      case GC_Pair:
      case GC_Triple:
      case GC_Quadruple:
      case GC_Vector:
	if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
	  break;
	old_head = (MEMORY_REF (wabbit, 0));
	MEMORY_SET (wabbit, 0, (MAKE_BROKEN_HEART (area)));
	*area++ = old_head;
	*area++ = wabbit;
	break;

      case GC_Compiled:
      {
	SCHEME_OBJECT * block;

	if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
	  break;

	Get_Compiled_Block (block, (OBJECT_ADDRESS (wabbit)));
	old_head = *block;
	*block = (MAKE_BROKEN_HEART (area));
	*area++ = old_head;
	*area++ = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
	break;
      }

      default:
	/* Loser -- shouldn't happen */
	break;
    }
  }
  old_wabbit_buffer_end = area;

  result = (wabbit_hunting_gcloop (wabbit_lo_address, &Free));
  if (Free != result)
  {
    outf_fatal ("\nwabbit_hunt: heap scan ended too early.\n");
    Microcode_Termination (TERM_BROKEN_HEART);
  }
  return;
}

void
DEFUN (duck_season, (wabbit_descriptor),
       SCHEME_OBJECT wabbit_descriptor)
{
  SCHEME_OBJECT * ptr;

  /* Restore hares' heads */

  for (ptr = old_wabbit_buffer; ptr < old_wabbit_buffer_end; ptr += 2)
    MEMORY_SET (ptr[1], 0, ptr[0]);

  wabbit_buffer_lo[2] =
    (LONG_TO_UNSIGNED_FIXNUM (wabbit_buffer_ptr - (wabbit_buffer_lo + 1)));
  while (wabbit_buffer_ptr < wabbit_buffer_hi)
    *wabbit_buffer_ptr++ = SHARP_F;
  wabbit_buffer_lo[1] = (BOOLEAN_TO_OBJECT (wabbit_all_dead_p));
  wabbit_buffer_lo[0]
    = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
		    (wabbit_buffer_hi - (wabbit_buffer_lo + 1))));

  if ((VECTOR_REF (wabbit_descriptor, 3)) == SHARP_T)
  {
    SCHEME_OBJECT * guaranteed_free = (Free + (GC_Reserve + 2));
    SCHEME_OBJECT * source, * dest, result;
    long len;

    if (guaranteed_free > wabbit_holes)
    {
      wabbit_holes_discarded_p = true;
      wabbit_holes = guaranteed_free;
    }
    dest = Free;
    result = (MAKE_POINTER_OBJECT (TC_VECTOR, dest));
    source = wabbit_holes;
    len = (wabbit_holes_hi - source);
    *dest++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len + 1)));
    *dest++ = (BOOLEAN_TO_OBJECT (! (wabbit_holes_discarded_p
				     || wabbit_holes_overwritten_p)));
    while (--len >= 0)
      *dest++ = *source++;
    Free = dest;
    VECTOR_SET (wabbit_descriptor, 3, result);
  }

  VECTOR_SET (wabbit_descriptor, 0, SHARP_T);
  return;
}

SCHEME_OBJECT *
DEFUN (hunt_wabbit, (where), SCHEME_OBJECT * where)
{
  SCHEME_OBJECT * ptr_lo, * ptr_hi, * ptr_mid, * hole;

  ptr_lo = wabbit_holes;
  ptr_hi = (wabbit_holes_hi - 1);

  while (ptr_lo < ptr_hi)
  {
    ptr_mid = (ptr_lo + ((ptr_hi - ptr_lo) / 2));
    hole = (OBJECT_ADDRESS (* ptr_mid));
    if (where < hole)
      ptr_lo = (ptr_mid + 1);
    else if (where > hole)
      ptr_hi = ptr_mid;
    else
    {
      ptr_hi = ptr_mid;
      ptr_lo = ptr_mid;
      break;
    }
  }
  return (ptr_lo);
}

Boolean
DEFUN (discard_wabbit_holes_p, (scan, free),
       SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
{
  SCHEME_OBJECT * hole, * new_hole;
  long keep_index;

  if (free > wabbit_holes)
  {
    wabbit_holes_overwritten_p = true;
    wabbit_holes = free;    
  }
  if (scan < Constant_Top)
    return (free < wabbit_holes);

  hole = ((hunt_wabbit (scan)) + 1);

  /* This guarantees that we don't get into quadratic copying:
     We discard only if the fraction of holes being discarded
     is at least 1/ELMER_HUNG_FACTOR of the total number of holes.
   */

  if ((ELMER_HUNG_FACTOR * (wabbit_holes_hi - hole))
      < (wabbit_holes_hi - wabbit_holes))
    return (free < wabbit_holes);

  keep_index = (hole - wabbit_holes);
  new_hole = wabbit_holes_hi;

  while (--keep_index >= 0)
    *--new_hole = *--hole;

  wabbit_holes = new_hole;
  wabbit_holes_discarded_p = true;
  return (free < wabbit_holes);
}

void
DEFUN (kill_da_wabbit, (where, current_object),
       SCHEME_OBJECT * where AND SCHEME_OBJECT current_object)
{
  SCHEME_OBJECT * hole, wabbit, * wabbit_addr;
  long offset, max_offset;

  /* With my sword and magic helmet... */

  if (where < Constant_Top)
  {
    SCHEME_OBJECT head;

    if (current_object != SHARP_F)
    {
      offset = (where - (OBJECT_ADDRESS (current_object)));
      head = current_object;
    }
    else
    {
      /* If we do cwcc before calling the special garbage collector,
	 there should be no references to the stack.
       */
      offset = 0;
      if (where < Stack_Top)
	head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_STACK, where));
      else
	head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_CONSTANT_SPACE, where));
    }

    *wabbit_buffer_ptr++ = head;
    *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));
    return;
  }
  if (wabbit_holes >= wabbit_holes_hi)
    return;

  hole = (hunt_wabbit (where));
  wabbit = (* hole);
  wabbit_addr = (OBJECT_ADDRESS (wabbit));
  offset = (where - wabbit_addr);
  *wabbit_buffer_ptr++ = wabbit;
  *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));

  if ((hole == wabbit_holes)
      && wabbit_holes_overwritten_p && (where != wabbit_addr))
  {
    switch (GC_Type_Map[(OBJECT_TYPE (wabbit))])
    {
      case GC_Pair:
        max_offset = 2;
	break;

      case GC_Triple:
        max_offset = 3;
	break;

      case GC_Quadruple:
        max_offset = 4;
	break;

      case GC_Vector:
	max_offset = (1 + (OBJECT_DATUM (* wabbit_addr)));
	break;
	
      case GC_Special:
        if ((OBJECT_TYPE (* hole)) == TC_REFERENCE_TRAP)
	{
	  max_offset = 2;
	  break;
	}
	/* fall through */

      case GC_Cell:	/* => (where == wabbit_addr), already tested */
      default:
	max_offset = -1;
    }
    if ((max_offset == -1) || (where > (wabbit_addr + max_offset)))
    {
      wabbit_buffer_ptr -= 2;
      wabbit_all_dead_p = false;
    }
  }
  return;
}

/* Alternate version of Fix_Weak_Chain that hunts wabbits. */

#ifndef EMPTY_WEAK_CHAIN
#define EMPTY_WEAK_CHAIN EMPTY_LIST
#endif

void
DEFUN_VOID (fix_weak_chain_and_hunt_wabbits)
{
  fast SCHEME_OBJECT
    * old_weak_pair, * scan, nulled_car, * new_space_addr,
    this_object, * old_space_addr, * low_heap;

  low_heap = Constant_Top;
  while (Weak_Chain != EMPTY_WEAK_CHAIN)
  {
    old_weak_pair = (OBJECT_ADDRESS (Weak_Chain));
    scan = (OBJECT_ADDRESS (*old_weak_pair++));
    Weak_Chain = * old_weak_pair;
    nulled_car = * scan;
    this_object = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, nulled_car));
    Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));

    switch (GC_Type (this_object))
    {
      case GC_Non_Pointer:
        *scan = this_object;
	continue;

      case GC_Special:
	if ((OBJECT_TYPE (this_object)) != TC_REFERENCE_TRAP)
	{
	  /* No other special type makes sense here. */
	  goto fail;
	}
	if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
	{
	  * scan = this_object;
	  continue;
	}
	/* Otherwise, it is a pointer.  Fall through */

      /* Normal pointer types, the broken heart is in the first word.
         Note that most special types are treated normally here.
       */
      case GC_Cell:
      case GC_Pair:
      case GC_Triple:
      case GC_Quadruple:
      case GC_Vector:
	* scan = this_object;	/* In case it points to constant space */
	RELOCATE_NORMAL_SETUP ();
	* scan = SHARP_F;
	continue;

      case GC_Compiled:
	* scan = this_object;
	old_space_addr = (OBJECT_ADDRESS (this_object));
	if (old_space_addr < low_heap)
	  continue;
	Get_Compiled_Block (old_space_addr, old_space_addr);
	if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)
	{
	  new_space_addr = (OBJECT_ADDRESS (* old_space_addr));
	  if (WABBIT_P (new_space_addr))
	    KILL_DA_WABBIT (scan, (MAKE_POINTER_OBJECT (TC_WEAK_CONS, scan)));
	    
	  * scan = (RELOCATE_COMPILED (this_object,
				       new_space_addr,
				       old_space_addr));
	  continue;
	}
	* scan = SHARP_F;
	continue;

      case GC_Undefined:
	outf_error
	  ("\nfix_weak_chain_and_hunt_wabbits: Clearing bad object 0x%08lx.\n",
	   this_object);
	* scan = SHARP_F;
	continue;

      default:			/* Non Marked Headers and Broken Hearts */
      fail:
        outf_fatal
	  ("\nfix_weak_chain_and_hunt_wabbits: Bad Object: 0x%08lx.\n",
	   this_object);
	* scan = SHARP_F;
	/*NOTREACHED*/
    }
  }
  return;
}

/* What did you expect from opera, a happy ending? */
