madness pasted by megane on Wed Apr 15 15:11:54 2020
//////////// 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);
}
mark added by megane on Fri Apr 17 16:07:13 2020
#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