Welcome to the CHICKEN Scheme pasting service

//////////// in C_reclaim
rescan:
// <-- XXXXXXXXXXX extracted the loop here to own function mark_nested
if(gc_mode == GC_MINOR) {
  mark_nested(GC_MINOR); // <- call here
  count = (C_uword)C_fromspace_top - (C_uword)start;
  ++gc_count_1;
  ++gc_count_1_total;
  update_locative_table(GC_MINOR);
 }
 else {
   mark_nested(gc_mode); // <- call here
   if(!finalizers_checked) {
////////////

static C_regparm void C_fcall mark_nested(int mode)
{
  C_word *p;
  C_uword bytes;
  C_SCHEME_BLOCK *bp;
  C_header h;
  // ----- XXXXXXX Capture some globals into globals so compiler has better time with aliasing
  double start_t = C_cpu_milliseconds();
  int n;
  int weak_gc_p = C_enable_gcweak;
  C_byte *fs_s = fromspace_start,
    *fs_l = C_fromspace_limit,
    *ts_s = tospace_start,
    *ts_l = tospace_limit;
  C_word
    *stack_bot = stack_bottom,
    *stack_p = C_stack_pointer_test;
  while(heap_scan_top < (mode == GC_MINOR ? C_fromspace_top : tospace_top)) {

    bp = (C_SCHEME_BLOCK *)heap_scan_top;

    if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
      bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);

    n = C_header_size(bp);
    h = bp->header;
    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
    p = bp->data;

    if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
      if(h & C_SPECIALBLOCK_BIT) {
        --n;
        ++p;
      }

      while(n--) { // ------------------------- XXXXXXXXXX manually inlined lots of stuff here
        // inlined mark(p++)
        C_word *_x = p++, _val = *_x;
        if(!C_immediatep(_val)) {
          C_word *wptr = (C_word *)(C_uword)_val;
          C_byte *ptr = (C_byte *)(C_uword)_val;
          if (
              // C_in_stackp
              in_stackp_3(_val, stack_p, stack_bot)
              // C_in_heapp
              || (fs_s <= ptr && ptr < fs_l)
              || (ts_s <= ptr && ptr < ts_l))
            if(mode == GC_MINOR) {
              really_mark_minor(_x);
            } else {
              if (weak_gc_p) {
                really_mark_major(_x, tospace_limit);
              } else {
                really_mark_major_no_weak(_x, tospace_limit);
              }
            }
        }
      }
    }

    heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
  }
  /* if(mode != GC_MINOR) printf("mark_nested: %.1f\n", C_cpu_milliseconds() - start_t); */
}


// XXXXXXXXXX Original really_mark

C_regparm void C_fcall really_mark(C_word *x)
{
  C_word val, item;
  C_uword n, bytes;
  C_header h;
  C_SCHEME_BLOCK *p, *p2;
  WEAK_TABLE_ENTRY *wep;

  val = *x;

  if (!C_in_stackp(val) && !C_in_heapp(val)) {
#ifdef C_GC_HOOKS
    if(C_gc_trace_hook != NULL)
      C_gc_trace_hook(x, gc_mode);
#endif

    return;
  }

  p = (C_SCHEME_BLOCK *)val;

  h = p->header;

  if(gc_mode == GC_MINOR) {
    if(is_fptr(h)) {
      *x = val = fptr_to_ptr(h);
      return;
    }

    if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return;

    p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);

#ifndef C_SIXTY_FOUR
    if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
      *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
      p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
    }
#endif

    n = C_header_size(p);
    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

    if(((C_byte *)p2 + bytes + sizeof(C_word)) > C_fromspace_limit)
#ifdef HAVE_SIGSETJMP
      C_siglongjmp(gc_restart, 1);
#else
    C_longjmp(gc_restart, 1);
#endif

    C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);

  scavenge:
    *x = (C_word)p2;
    p2->header = h;
    p->header = ptr_to_fptr((C_uword)p2);
    C_memcpy(p2->data, p->data, bytes);
  }
  else { /* (major GC) */
    /* Increase counter (saturated at 2) if weakly held item (someone pointed to this object): */
    if(C_enable_gcweak &&
       (h & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
       (wep = lookup_weak_table_entry(val, 0)) != NULL) {
      if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
    }

    if(is_fptr(h)) {
      val = fptr_to_ptr(h);

      /* When we marked the bucket, it may have already referred to
       * the moved symbol instead of its original location. Re-check:
       */
      if(C_enable_gcweak &&
         (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
         (wep = lookup_weak_table_entry(*x, 0)) != NULL) {
        if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
      }

      if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
	*x = val;
	return;
      }

      /* Link points into fromspace: fetch new pointer + header and copy... */
      p = (C_SCHEME_BLOCK *)val;
      h = p->header;

      if(is_fptr(h)) {
	/* Link points into fromspace and into a link which points into from- or tospace: */
	val = fptr_to_ptr(h);

        /* See above: might happen twice */
        if(C_enable_gcweak &&
           (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
           /* Check both the original and intermediate location: */
           ((wep = lookup_weak_table_entry((C_word)p, 0)) != NULL ||
            (wep = lookup_weak_table_entry(*x, 0)) != NULL)) {
          if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
        }

	if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
	  *x = val;
	  return;
	}

	p = (C_SCHEME_BLOCK *)val;
	h = p->header;
      }
    }

    p2 = (C_SCHEME_BLOCK *)C_align((C_uword)tospace_top);

#ifndef C_SIXTY_FOUR
    if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tospace_limit) {
      *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
      p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
    }
#endif

    if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
      item = C_block_item(val,0);

      /* Lookup item in weak item table or add entry: */
      if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
	/* If item is already forwarded, then set count to 2: */
	if(is_fptr(C_block_header(item))) wep->container |= 2;
      }
    }

    n = C_header_size(p);
    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

    if(((C_byte *)p2 + bytes + sizeof(C_word)) > tospace_limit) {
      /* Detect impossibilities before GC_REALLOC to preserve state: */
      if (C_in_stackp((C_word)p) && bytes > stack_size)
        panic(C_text("Detected corrupted data in stack"));
      if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))
        panic(C_text("Detected corrupted data in heap"));
      if(C_heap_size_is_fixed)
	panic(C_text("out of memory - heap full"));

      gc_mode = GC_REALLOC;
#ifdef HAVE_SIGSETJMP
      C_siglongjmp(gc_restart, 1);
#else
      C_longjmp(gc_restart, 1);
#endif
    }

    tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
    goto scavenge;
  }
}

// XXXXXXXXXXXX New really_mark

C_regparm void C_fcall really_mark(C_word *x)
{
  if(gc_mode == GC_MINOR)
    really_mark_minor(x);
  else
    really_mark_major(x, tospace_limit);
}

// XXXXXXXXXXXXX These functions are just subsets of the original really_mark that
// make "assumptions" so conditionals can be removed

C_regparm void C_fcall really_mark_major(C_word *x, C_byte *ts_limit)
 {
   C_word val, item;
   C_uword n, bytes;
   C_header h;
   C_SCHEME_BLOCK *p, *p2;
   WEAK_TABLE_ENTRY *wep;
   int weak_gc_p = C_enable_gcweak;
   C_uword ts_s = (C_uword)tospace_start,
     ts_top = (C_uword)tospace_top;

   val = *x;

   p = (C_SCHEME_BLOCK *)val;

   h = p->header;

   /* Increase counter (saturated at 2) if weakly held item (someone pointed to this object): */
   if(weak_gc_p &&
      (h & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
      (wep = lookup_weak_table_entry(val, 0)) != NULL) {
     if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
   }

   if(is_fptr(h)) {
     val = fptr_to_ptr(h);

     /* When we marked the bucket, it may have already referred to
      * the moved symbol instead of its original location. Re-check:
      */
     if(weak_gc_p &&
        (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
        (wep = lookup_weak_table_entry(*x, 0)) != NULL) {
       if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
     }

     if((C_uword)val >= ts_s && (C_uword)val < ts_top) {
       *x = val;
       return;
     }

     /* Link points into fromspace: fetch new pointer + header and copy... */
     p = (C_SCHEME_BLOCK *)val;
     h = p->header;

     if(is_fptr(h)) {
       /* Link points into fromspace and into a link which points into from- or tospace: */
       val = fptr_to_ptr(h);

       /* See above: might happen twice */
       if(weak_gc_p &&
          (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE &&
          /* Check both the original and intermediate location: */
          ((wep = lookup_weak_table_entry((C_word)p, 0)) != NULL ||
           (wep = lookup_weak_table_entry(*x, 0)) != NULL)) {
         if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
       }

       if((C_uword)val >= ts_s && (C_uword)val < ts_top) {
         *x = val;
         return;
       }

       p = (C_SCHEME_BLOCK *)val;
       h = p->header;
     }
   }

   p2 = (C_SCHEME_BLOCK *)C_align(ts_top);

#ifndef C_SIXTY_FOUR
   if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < ts_limit) {
     *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
     p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
   }
#endif

   if(weak_gc_p && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
     item = C_block_item(val,0);

     /* Lookup item in weak item table or add entry: */
     if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
       /* If item is already forwarded, then set count to 2: */
       if(is_fptr(C_block_header(item))) wep->container |= 2;
     }
   }

   n = C_header_size(p);
   bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

   if(((C_byte *)p2 + bytes + sizeof(C_word)) > ts_limit) {
     /* Detect impossibilities before GC_REALLOC to preserve state: */
     if (C_in_stackp((C_word)p) && bytes > stack_size)
       panic(C_text("Detected corrupted data in stack"));
     if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))
       panic(C_text("Detected corrupted data in heap"));
     if(C_heap_size_is_fixed)
       panic(C_text("out of memory - heap full"));

     gc_mode = GC_REALLOC;
#ifdef HAVE_SIGSETJMP
     C_siglongjmp(gc_restart, 1);
#else
     C_longjmp(gc_restart, 1);
#endif
   }

   tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
   // inlined goot scanvege;
   *x = (C_word)p2;
   p2->header = h;
   p->header = ptr_to_fptr((C_uword)p2);
   C_memcpy(p2->data, p->data, bytes);
 }

C_regparm void C_fcall really_mark_major_no_weak(C_word *x, C_byte *ts_limit) {
  C_word val, item;
  C_uword n, bytes;
  C_header h;
  C_SCHEME_BLOCK *p, *p2;
  WEAK_TABLE_ENTRY *wep;
  C_uword ts_s = (C_uword)tospace_start,
    ts_top = (C_uword)tospace_top;

  val = *x;

  p = (C_SCHEME_BLOCK *)val;

  h = p->header;

  /* Increase counter (saturated at 2) if weakly held item (someone pointed to this object): */

  if(is_fptr(h)) {
    val = fptr_to_ptr(h);

    /* When we marked the bucket, it may have already referred to
     * the moved symbol instead of its original location. Re-check:
     */

    if((C_uword)val >= ts_s && (C_uword)val < ts_top) {
      *x = val;
      return;
    }

    /* Link points into fromspace: fetch new pointer + header and copy... */
    p = (C_SCHEME_BLOCK *)val;
    h = p->header;

    if(is_fptr(h)) {
      /* Link points into fromspace and into a link which points into from- or tospace: */
      val = fptr_to_ptr(h);

      if((C_uword)val >= ts_s && (C_uword)val < ts_top) {
        *x = val;
        return;
      }

      p = (C_SCHEME_BLOCK *)val;
      h = p->header;
    }
  }

  p2 = (C_SCHEME_BLOCK *)C_align(ts_top);

#ifndef C_SIXTY_FOUR
  if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < ts_limit) {
    *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
    p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
  }
#endif

  n = C_header_size(p);
  bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

  if(((C_byte *)p2 + bytes + sizeof(C_word)) > ts_limit) {
    /* Detect impossibilities before GC_REALLOC to preserve state: */
    if (C_in_stackp((C_word)p) && bytes > stack_size)
      panic(C_text("Detected corrupted data in stack"));
    if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))
      panic(C_text("Detected corrupted data in heap"));
    if(C_heap_size_is_fixed)
      panic(C_text("out of memory - heap full"));

    gc_mode = GC_REALLOC;
#ifdef HAVE_SIGSETJMP
    C_siglongjmp(gc_restart, 1);
#else
    C_longjmp(gc_restart, 1);
#endif
  }

  tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
  // XXXXXXXXXX inlined goot scanvege;
  *x = (C_word)p2;
  p2->header = h;
  p->header = ptr_to_fptr((C_uword)p2);
  C_memcpy(p2->data, p->data, bytes);
}

C_regparm void C_fcall really_mark_minor_2(C_word *x, C_uword fs_start, C_byte *fs_limit) {
  C_word val;
  C_uword n, bytes;
  C_header h;
  C_SCHEME_BLOCK *p, *p2;

  val = *x;

  p = (C_SCHEME_BLOCK *)val;

  h = p->header;

  n = C_header_size(p);
  bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

  if(is_fptr(h)) {
    *x = val = fptr_to_ptr(h);
    return;
  }

  if((C_uword)val >= fs_start && (C_uword)val < (C_uword)C_fromspace_top) return;

  p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);

#ifndef C_SIXTY_FOUR
  if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < fs_limit) {
    *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
    p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
  }
#endif

  if(((C_byte *)p2 + bytes + sizeof(C_word)) > fs_limit)
#ifdef HAVE_SIGSETJMP
    C_siglongjmp(gc_restart, 1);
#else
  C_longjmp(gc_restart, 1);
#endif

  C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);

  // XXXXXXXXX old scavenge: label
  *x = (C_word)p2;
  p2->header = h;
  p->header = ptr_to_fptr((C_uword)p2);
  C_memcpy(p2->data, p->data, bytes);
}

C_regparm void C_fcall really_mark_minor(C_word *x) {
  C_word val;
  C_uword n, bytes;
  C_header h;
  C_SCHEME_BLOCK *p, *p2;

  val = *x;

  p = (C_SCHEME_BLOCK *)val;

  h = p->header;

  n = C_header_size(p);
  bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);

  if(is_fptr(h)) {
    *x = val = fptr_to_ptr(h);
    return;
  }

  if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return;

  p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);

#ifndef C_SIXTY_FOUR
  if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
    *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
    p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
  }
#endif

  if(((C_byte *)p2 + bytes + sizeof(C_word)) > C_fromspace_limit)
#ifdef HAVE_SIGSETJMP
    C_siglongjmp(gc_restart, 1);
#else
  C_longjmp(gc_restart, 1);
#endif

  C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);

  // XXXXXX old scavenge: label
  *x = (C_word)p2;
  p2->header = h;
  p->header = ptr_to_fptr((C_uword)p2);
  C_memcpy(p2->data, p->data, bytes);
}

#ifdef __SUNPRO_C
static void mark(C_word *x) { \
  C_word *_x = (x), _val = *_x; \
  if(!C_immediatep(_val)) really_mark(_x); \
}
#else
# define mark(x)				\
  C_cblock                                      \
  C_word *_x = (x), _val = *_x;                 \
  if(!C_immediatep(_val)) {                     \
    if (C_in_stackp(_val) || C_in_heapp(_val))  \
      really_mark(_x);                          \
  }                                             \
  C_cblockend
#endif