generational GC work

TODO.FACTOR.txt

@@ -1,3 +1,11 @@
+<magnus--> http://developer.apple.com/technotes/tn2004/tn2123.html#SECLIMITATIONS
+<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4742.html
+<magnus--> not *too* long
+<magnus--> but we'd need to longjmp the main thread from the exception handler thread
+<magnus--> or cause a signal in the main thread
+<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
+<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
+
 - faster layout
 - tiled window manager
 - c primitive arrays: or just specialized arrays

library/bootstrap/boot-stage4.factor

@@ -3,8 +3,8 @@
 IN: kernel
 USING: alien assembler command-line compiler console errors
 generic inference kernel-internals listener lists math memory
-namespaces parser presentation random stdio streams unparser
+namespaces parser presentation prettyprint random stdio streams
-words ;
+unparser words ;
 
 "Bootstrap stage 4..." print
 
@@ -42,6 +42,8 @@ unparse write " words compiled" print
 0 [ drop 1 + ] each-word
 unparse write " words total" print 
 
+"Total bootstrap GC time: " write gc-time unparse write " ms" print
+
 "Bootstrapping is complete." print
 "Now, you can run ./f factor.image" print
 

library/bootstrap/primitives.factor

@@ -126,7 +126,7 @@ vocabularies get [
     [ "setenv" "kernel-internals"             [ [ object fixnum ] [ ] ] ]
     [ "stat" "files"                          [ [ string ] [ general-list ] ] ]
     [ "(directory)" "files"                   [ [ string ] [ general-list ] ] ]
-    [ "garbage-collection" "memory"           [ [ ] [ ] ] ]
+    [ "gc" "memory"                           [ [ fixnum ] [ ] ] ]
     [ "gc-time" "memory"                      [ [ string ] [ ] ] ]
     [ "save-image" "memory"                   [ [ string ] [ ] ] ]
     [ "datastack" "kernel"                    " -- ds "          ]
@@ -134,7 +134,7 @@ vocabularies get [
     [ "set-datastack" "kernel"                " ds -- "          ]
     [ "set-callstack" "kernel"                " cs -- "          ]
     [ "exit" "kernel"                         [ [ integer ] [ ] ] ]
-    [ "room" "memory"                         [ [ ] [ integer integer general-list ] ] ]
+    [ "room" "memory"                         [ [ ] [ integer integer integer integer general-list ] ] ]
     [ "os-env" "kernel"                       [ [ string ] [ object ] ] ]
     [ "millis" "kernel"                       [ [ ] [ integer ] ] ]
     [ "(random-int)" "math"                   [ [ ] [ integer ] ] ]

library/test/compiler/simple.factor

@@ -34,7 +34,7 @@ USE: memory
 
 : indexed-literal-test "hello world" ; compiled
 
-garbage-collection
+full-gc
-garbage-collection
+full-gc
 
 [ "hello world" ] [ indexed-literal-test ] unit-test

library/test/crashes.factor

@@ -6,7 +6,7 @@ prettyprint sequences strings test vectors words ;
 
 [ ] [
     "20 <sbuf> \"foo\" set" eval
-    "garbage-collection" eval
+    "full-gc" eval
 ] unit-test
 
 [ ] [
@@ -26,6 +26,6 @@ prettyprint sequences strings test vectors words ;
 ! Weird PowerPC bug.
 [ ] [
     [ "4" throw ] [ drop ] catch
-    garbage-collection
+    full-gc
-    garbage-collection
+    full-gc
 ] unit-test

library/tools/memory.factor

@@ -5,6 +5,10 @@ USING: errors generic hashtables kernel kernel-internals lists
 math namespaces prettyprint sequences stdio strings unparser
 vectors words ;
 
+: generations 15 getenv ;
+
+: full-gc generations 1 - gc ;
+
 : save
     #! Save the current image.
     "image" get save-image ;

native/alien.c

@@ -87,7 +87,7 @@ void fixup_displaced_alien(DISPLACED_ALIEN* d)
 
 void collect_displaced_alien(DISPLACED_ALIEN* d)
 {
-	COPY_OBJECT(d->alien);
+	copy_handle(&d->alien);
 }
 
 #define DEF_ALIEN_SLOT(name,type,boxer) \

native/array.c

@@ -14,6 +14,12 @@ F_ARRAY* allot_array(CELL type, CELL capacity)
 	return array;
 }
 
+/* WARNING: fill must be an immediate type:
+either be F or a fixnum.
+
+if you want to use pass a pointer, you _must_ hit
+the write barrier manually with a write_barrier()
+call with the returned object. */
 F_ARRAY* array(CELL type, CELL capacity, CELL fill)
 {
 	int i; F_ARRAY* array = allot_array(type, capacity);
@@ -40,9 +46,9 @@ void primitive_byte_array(void)
 	dpush(tag_object(array(BYTE_ARRAY_TYPE,to_fixnum(dpop()),0)));
 }
 
+/* see note about fill in array() */
 F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
 {
-	/* later on, do an optimization: if end of array is here, just grow */
 	int i; F_ARRAY* new_array;
 	CELL curr_cap = array_capacity(array);
 	if(curr_cap >= capacity)

native/debug.c

@@ -135,32 +135,184 @@ void print_obj(CELL obj)
 		fprintf(stderr,"f");
 		break;
 	default:
-		fprintf(stderr,"#<type %ld @ %ld>",type_of(obj),obj);
+		fprintf(stderr,"#<type %ld @ %lx>",type_of(obj),obj);
 		break;
 	}
 }
 
-void print_stack(CELL* start, CELL* end)
+void print_objects(CELL start, CELL end)
 {
-	while(start < end)
+	for(; start <= end; start += CELLS)
 	{
-		print_obj(*start);
+		print_obj(get(start));
 		fprintf(stderr,"\n");
-		start++;
 	}
 }
 
-void dump_stacks(void)
+void dump_cell(CELL cell)
 {
-	fprintf(stderr,"*** Data stack:\n");
+	fprintf(stderr,"%08lx: ",cell);
-	print_stack((CELL*)ds_bot,(CELL*)(ds + CELLS));
+
-	fprintf(stderr,"*** Call stack:\n");
+	cell = get(cell);
-	print_stack((CELL*)cs_bot,(CELL*)(cs + CELLS));
+
-	fprintf(stderr,"*** Call frame:\n");
+	fprintf(stderr,"%08lx tag %ld",cell,TAG(cell));
-	print_obj(callframe);
+
+	switch(TAG(cell))
+	{
+	case OBJECT_TYPE:
+	case BIGNUM_TYPE:
+	case FLOAT_TYPE:
+		if(cell == F)
+			fprintf(stderr," -- F");
+		else if(cell < TYPE_COUNT<<TAG_BITS)
+			fprintf(stderr," -- header: %ld",cell>>TAG_BITS);
+		else if(cell >= heap_start && cell < heap_end)
+		{
+			CELL header = get(UNTAG(cell));
+			CELL type = header>>TAG_BITS;
+			fprintf(stderr," -- object; ");
+			if(TAG(header) == OBJECT_TYPE && type < TYPE_COUNT)
+				fprintf(stderr," type %ld",type);
+			else
+				fprintf(stderr," header corrupt");
+		}
+		break;
+	case GC_COLLECTED:
+		fprintf(stderr," -- forwarding pointer");
+		break;
+	}
+	
 	fprintf(stderr,"\n");
-	fprintf(stderr,"*** Executing:\n");
+}
-	print_obj(executing);
+
-	fprintf(stderr,"\n");
+void dump_memory(CELL from, CELL to)
-	fflush(stderr);
+{
+	for(; from <= to; from += CELLS)
+		dump_cell(from);
+}
+
+void dump_generation(ZONE *z)
+{
+	fprintf(stderr,"base=%lx, size=%lx, here=%lx, alarm=%lx\n",
+		z->base,
+		z->limit - z->base,
+		z->here - z->base,
+		z->alarm - z->base);
+}
+
+void dump_generations(void)
+{
+	int i;
+	for(i = 0; i < GC_GENERATIONS; i++)
+	{
+		fprintf(stderr,"Generation %d: ",i);
+		dump_generation(&generations[i]);
+	}
+
+	fprintf(stderr,"Semispace: ");
+	dump_generation(&prior);
+
+	fprintf(stderr,"Cards: base=%lx, size=%lx\n",(CELL)cards,
+		(CELL)(cards_end - cards));
+}
+
+void factorbug(void)
+{
+	fprintf(stderr,"Factor low-level debugger\n");
+	fprintf(stderr,"d <addr> <count> -- dump memory\n");
+	fprintf(stderr,". <addr>         -- print object at <addr>\n");
+	fprintf(stderr,"sz <addr>        -- print size of object at <addr>\n");
+	fprintf(stderr,"s r              -- dump data and return stacks\n");
+	fprintf(stderr,".s .r            -- print data and return stacks\n");
+	fprintf(stderr,"i                -- dump interpreter state\n");
+	fprintf(stderr,"e                -- dump environment\n");
+	fprintf(stderr,"g                -- dump generations\n");
+	fprintf(stderr,"card <addr>      -- print card containing address\n");
+	fprintf(stderr,"addr <card>      -- print address containing card\n");
+	fprintf(stderr,"c <gen>          -- force garbage collection\n");
+	fprintf(stderr,"t                -- throw t\n");
+	fprintf(stderr,"x                -- exit debugger\n");
+	fprintf(stderr,"im               -- save factor.crash.image\n");
+	
+	for(;;)
+	{
+		char cmd[1024];
+
+		fprintf(stderr,"ldb ");
+		fflush(stdout);
+
+		if(scanf("%s",cmd) <= 0)
+			exit(1);
+
+		if(strcmp(cmd,"d") == 0)
+		{
+			CELL addr, count;
+			scanf("%lx %lx",&addr,&count);
+			dump_memory(addr,addr+count);
+		}
+		else if(strcmp(cmd,".") == 0)
+		{
+			CELL addr;
+			scanf("%lx",&addr);
+			print_obj(addr);
+			fprintf(stderr,"\n");
+		}
+		else if(strcmp(cmd,"sz") == 0)
+		{
+			CELL addr;
+			scanf("%lx",&addr);
+			fprintf(stderr,"%ld\n",object_size(addr));
+		}
+		else if(strcmp(cmd,"s") == 0)
+			dump_memory(ds_bot,(ds + CELLS));
+		else if(strcmp(cmd,"r") == 0)
+			dump_memory(cs_bot,(cs + CELLS));
+		else if(strcmp(cmd,".s") == 0)
+			print_objects(ds_bot,(ds + CELLS));
+		else if(strcmp(cmd,".r") == 0)
+			print_objects(cs_bot,(cs + CELLS));
+		else if(strcmp(cmd,"i") == 0)
+		{
+			fprintf(stderr,"Call frame:\n");
+			dump_cell(callframe);
+			fprintf(stderr,"\n");
+			fprintf(stderr,"Executing:\n");
+			dump_cell(executing);
+			fprintf(stderr,"\n");
+		}
+		else if(strcmp(cmd,"e") == 0)
+		{
+			int i;
+			for(i = 0; i < USER_ENV; i++)
+				dump_cell(userenv[i]);
+		}
+		else if(strcmp(cmd,"g") == 0)
+			dump_generations();
+		else if(strcmp(cmd,"c") == 0)
+		{
+			CELL gen;
+			scanf("%lu",&gen);
+			garbage_collection(gen);
+		}
+		else if(strcmp(cmd,"card") == 0)
+		{
+			CELL addr;
+			scanf("%lx",&addr);
+			fprintf(stderr,"%lx\n",(CELL)ADDR_TO_CARD(addr));
+		}
+		else if(strcmp(cmd,"addr") == 0)
+		{
+			CELL card;
+			scanf("%lx",&card);
+			fprintf(stderr,"%lx\n",(CELL)CARD_TO_ADDR(card));
+		}
+		else if(strcmp(cmd,"t") == 0)
+			throw_error(T,true);
+		else if(strcmp(cmd,"x") == 0)
+			return;
+		else if(strcmp(cmd,"y") == 0)
+			save_image("factor.crash.image");
+		else
+			fprintf(stderr,"unknown command\n");
+	}
 }

native/debug.h

@@ -1,7 +1,3 @@
-CELL assoc(CELL alist, CELL key);
-void print_cons(CELL cons);
-void print_word(F_WORD* word);
-void print_string(F_STRING* str);
 void print_obj(CELL obj);
-void print_stack(CELL* start, CELL* end);
+void dump_generations(void);
-void dump_stacks(void);
+void factorbug(void);

native/dll.c

@@ -53,5 +53,5 @@ void fixup_dll(DLL* dll)
 
 void collect_dll(DLL* dll)
 {
-	COPY_OBJECT(dll->path);
+	copy_handle(&dll->path);
 }

native/error.c

@@ -14,8 +14,7 @@ void fatal_error(char* msg, CELL tagged)
 void critical_error(char* msg, CELL tagged)
 {
 	fprintf(stderr,"Critical error: %s %ld\n",msg,tagged);
-	save_image("factor.crash.image");
+	factorbug();
-	exit(1);
 }
 
 void early_error(CELL error)
@@ -26,9 +25,7 @@ void early_error(CELL error)
 		fprintf(stderr,"Error during startup: ");
 		print_obj(error);
 		fprintf(stderr,"\n");
-		dump_stacks();
+		factorbug();
-		fflush(stderr);
-		exit(1);
 	}
 }
 
@@ -60,9 +57,7 @@ void primitive_throw(void)
 
 void primitive_die(void)
 {
-	dump_stacks();
+	factorbug();
-	fflush(stderr);
-	exit(1);
 }
 
 void general_error(CELL error, CELL tagged)

native/factor.c

@@ -15,6 +15,7 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
 	init_errors();
 	userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));
 	userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING));
+	userenv[GEN_ENV] = tag_fixnum(GC_GENERATIONS);
 }
 
 INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
@@ -33,8 +34,8 @@ int main(int argc, char** argv)
 {
 	CELL ds_size = 2048;
 	CELL cs_size = 2048;
-	CELL young_size = 4;
+	CELL young_size = 8;
-	CELL aging_size = 8;
+	CELL aging_size = 16;
 	CELL code_size = 2;
 	CELL literal_size = 64;
 	CELL args;

native/gc.c

@@ -7,17 +7,13 @@ void collect_roots(void)
 	int i;
 	CELL ptr;
 
-	gc_debug("root: t",T);
+	copy_handle(&T);
-	COPY_OBJECT(T);
+	copy_handle(&bignum_zero);
-	gc_debug("root: bignum_zero",bignum_zero);
+	copy_handle(&bignum_pos_one);
-	COPY_OBJECT(bignum_zero);
+	copy_handle(&bignum_neg_one);
-	gc_debug("root: bignum_pos_one",bignum_pos_one);
+	/* we can't use & here since these two are in
-	COPY_OBJECT(bignum_pos_one);
+	registers on PowerPC */
-	gc_debug("root: bignum_neg_one",bignum_neg_one);
-	COPY_OBJECT(bignum_neg_one);
-	gc_debug("root: callframe",callframe);
 	COPY_OBJECT(callframe);
-	gc_debug("root: executing",executing);
 	COPY_OBJECT(executing);
 
 	for(ptr = ds_bot; ptr <= ds; ptr += CELLS)
@@ -30,22 +26,68 @@ void collect_roots(void)
 		copy_handle(&userenv[i]);
 }
 
+/* Given a pointer to oldspace, copy it to newspace. */
+INLINE void* copy_untagged_object(void* pointer, CELL size)
+{
+	void* newpointer = allot(size);
+	memcpy(newpointer,pointer,size);
+
+	return newpointer;
+}
+
+INLINE CELL copy_object_impl(CELL pointer)
+{
+	CELL newpointer;
+
+	if(pointer < collecting_generation)
+		critical_error("asked to copy object outside collected generation",pointer);
+	
+	newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
+		object_size(pointer));
+
+	/* install forwarding pointer */
+	put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
+
+	return newpointer;
+}
+
 /*
 Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 If the object has already been copied, return the forwarding
 pointer address without copying anything; otherwise, install
 a new forwarding pointer.
 */
-CELL copy_object_impl(CELL pointer)
+CELL copy_object(CELL pointer)
 {
-	CELL newpointer;
+	CELL tag;
+	CELL header;
+	CELL untagged;
 
-	gc_debug("copy_object",pointer);
+	gc_debug("copy object",pointer);
-	newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
-		object_size(pointer));
-	put(UNTAG(pointer),RETAG(newpointer,OBJECT_TYPE));
 
-	return newpointer;
+	if(pointer == F)
+		return F;
+
+	tag = TAG(pointer);
+
+	if(tag == FIXNUM_TYPE)
+		return pointer;
+
+	header = get(UNTAG(pointer));
+	untagged = UNTAG(header);
+	if(TAG(header) == GC_COLLECTED)
+	{
+		header = get(untagged);
+		while(header == GC_COLLECTED)
+		{
+			untagged = UNTAG(header);
+			header = get(untagged);
+		}
+		gc_debug("forwarding",untagged);
+		return RETAG(untagged,tag);
+	}
+	else
+		return RETAG(copy_object_impl(pointer),tag);
 }
 
 INLINE void collect_object(CELL scan)
@@ -80,8 +122,6 @@ INLINE void collect_object(CELL scan)
 INLINE CELL collect_next(CELL scan)
 {
 	CELL size;
-	gc_debug("collect_next",scan);
-	gc_debug("collect_next header",get(scan));
 	if(headerp(get(scan)))
 	{
 		size = untagged_object_size(scan);
@@ -96,15 +136,8 @@ INLINE CELL collect_next(CELL scan)
 	return scan + size;
 }
 
-void clear_cards(void)
-{
-	BYTE *ptr;
-	for(ptr = cards; ptr < cards_end; ptr++)
-		clear_card(ptr);
-}
-
 /* scan all the objects in the card */
-void collect_card(CARD *ptr)
+INLINE void collect_card(CARD *ptr, CELL here)
 {
 	CARD c = *ptr;
 	CELL offset = (c & CARD_BASE_MASK);
@@ -112,32 +145,66 @@ void collect_card(CARD *ptr)
 	CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
 
 	if(offset == 0x7f)
-		critical_error("bad card",c);
+	{
+		if(c == 0xff)
+			critical_error("bad card",c);
+		else
+			return;
+	}
 
-	printf("! write barrier hit %d\n",offset);
+	/* printf("write barrier hit %ld\n",offset); */
-	while(card_scan < card_end)
+	while(card_scan < card_end && card_scan < here)
 		card_scan = collect_next(card_scan);
-
-	clear_card(ptr);
 }
 
-void collect_gen_cards(CELL gen)
+INLINE void collect_gen_cards(CELL gen)
 {
 	CARD *ptr = ADDR_TO_CARD(generations[gen].base);
-	CARD *last_card = ADDR_TO_CARD(generations[gen].here);
+	CELL here = generations[gen].here;
-	for(ptr = cards; ptr <= last_card; ptr++)
+	CARD *last_card = ADDR_TO_CARD(here);
+	
+	if(generations[gen].here == generations[gen].limit)
+		last_card--;
+	
+	for(; ptr <= last_card; ptr++)
 	{
 		if(card_marked(*ptr))
-			collect_card(ptr);
+			collect_card(ptr,here);
 	}
 }
 
-/* scan cards in all generations older than the one being collected */
+void unmark_cards(CELL from, CELL to)
-void collect_cards(void)
 {
-	CELL gen;
+	CARD *ptr = ADDR_TO_CARD(generations[from].base);
-	for(gen = collecting_generation; gen < GC_GENERATIONS; gen++)
+	CARD *last_card = ADDR_TO_CARD(generations[to].here);
-		collect_gen_cards(gen);
+	if(generations[to].here == generations[to].limit)
+		last_card--;
+	for(; ptr <= last_card; ptr++)
+		unmark_card(ptr);
+}
+
+void clear_cards(CELL from, CELL to)
+{
+	CARD *ptr = ADDR_TO_CARD(generations[from].base);
+	CARD *last_card = ADDR_TO_CARD(generations[to].limit);
+	for(; ptr < last_card; ptr++)
+		clear_card(ptr);
+}
+
+void reset_generations(CELL from, CELL to)
+{
+	CELL i;
+	for(i = from; i <= to; i++)
+		generations[i].here = generations[i].base;
+	clear_cards(from,to);
+}
+
+/* scan cards in all generations older than the one being collected */
+void collect_cards(CELL gen)
+{
+	int i;
+	for(i = gen + 1; i < GC_GENERATIONS; i++)
+		collect_gen_cards(i);
 }
 
 void begin_gc(CELL gen)
@@ -153,6 +220,7 @@ void begin_gc(CELL gen)
 		prior = z;
 		generations[gen].here = generations[gen].base;
 		allot_zone = &generations[gen];
+		clear_cards(TENURED,TENURED);
 	}
 	else
 	{
@@ -165,7 +233,29 @@ void begin_gc(CELL gen)
 
 void end_gc(CELL gen)
 {
-	/* continue allocating from the nursery. */
+	if(gen == TENURED)
+	{
+		/* we did a full collection; no more
+		old-to-new pointers remain since everything
+		is in tenured space */
+		unmark_cards(TENURED,TENURED);
+		/* all generations except tenured space are
+		now empty */
+		reset_generations(NURSERY,TENURED - 1);
+	}
+	else
+	{
+		/* we collected a younger generation. so the
+		next-oldest generation no longer has any
+		pointers into the younger generation (the
+		younger generation is empty!) */
+		unmark_cards(gen + 1,gen + 1);
+		/* all generations up to and including the one
+		collected are now empty */
+		reset_generations(NURSERY,gen);
+	}
+
+	/* new objects are allocated from the nursery. */
 	allot_zone = &nursery;
 }
 
@@ -186,32 +276,41 @@ void garbage_collection(CELL gen)
 
 	begin_gc(gen);
 
+	printf("collecting generation %ld\n",gen);
+	dump_generations();
+
 	/* initialize chase pointer */
 	scan = allot_zone->here;
 
+	/* collect objects referenced from stacks and environment */
 	collect_roots();
-	collect_cards();
+	
+	/* collect objects referenced from older generations */
+	collect_cards(gen);
 
 	/* collect literal objects referenced from compiled code */
 	collect_literals();
 	
 	while(scan < allot_zone->here)
-	{
-		gc_debug("scan loop",scan);
 		scan = collect_next(scan);
-	}
 
 	end_gc(gen);
 
-	gc_debug("gc done",0);
+	gc_debug("gc done",gen);
 
 	gc_in_progress = false;
 	gc_time += (current_millis() - start);
+	
+	gc_debug("total gc time",gc_time);
 }
 
 void primitive_gc(void)
 {
-	garbage_collection(TENURED);
+	CELL gen = to_fixnum(dpop());
+	gen = MAX(NURSERY,MIN(TENURED,gen));
+	garbage_collection(gen);
+	printf("After:\n");
+	dump_generations();
 }
 
 /* WARNING: only call this from a context where all local variables
@@ -219,7 +318,21 @@ are also reachable via the GC roots. */
 void maybe_garbage_collection(void)
 {
 	if(nursery.here > nursery.alarm)
-		primitive_gc();
+	{
+		if(tenured.here > tenured.alarm)
+		{
+			printf("Major GC\n");
+			garbage_collection(TENURED);
+		}
+		else
+		{
+			printf("Minor GC\n");
+			garbage_collection(NURSERY);
+		}
+		
+		printf("After:\n");
+		dump_generations();
+	}
 }
 
 void primitive_gc_time(void)

native/gc.h

@@ -14,67 +14,25 @@ so we have to check that the pointer occurs after the beginning of
 the requested generation. */
 #define COLLECTING_GEN(ptr) (collecting_generation <= ptr)
 
-/* Given a pointer to oldspace, copy it to newspace. */
-INLINE void* copy_untagged_object(void* pointer, CELL size)
-{
-	void* newpointer = allot(size);
-	memcpy(newpointer,pointer,size);
-
-	return newpointer;
-}
-
-CELL copy_object_impl(CELL pointer);
-
 /* #define GC_DEBUG */
 
 INLINE void gc_debug(char* msg, CELL x) {
 #ifdef GC_DEBUG
-	printf("%s %d\n",msg,x);
+	printf("%s %ld\n",msg,x);
 #endif
 }
 
-INLINE CELL copy_object(CELL pointer)
+CELL copy_object(CELL pointer);
-{
+#define COPY_OBJECT(lvalue) if(COLLECTING_GEN(lvalue)) lvalue = copy_object(lvalue)
-	CELL tag;
-	CELL header;
-	CELL untagged;
 
-	gc_debug("copy object",pointer);
+INLINE void copy_handle(CELL *handle)
-
-	if(!COLLECTING_GEN(pointer))
-		return pointer;
-
-	if(pointer == F)
-		return F;
-
-	tag = TAG(pointer);
-
-	if(tag == FIXNUM_TYPE)
-		return pointer;
-
-	header = get(UNTAG(pointer));
-	untagged = UNTAG(header);
-	if(TAG(header) != FIXNUM_TYPE && in_zone(&tenured,untagged))
-	{
-		gc_debug("forwarding",untagged);
-		return RETAG(untagged,tag);
-	}
-	else
-		return RETAG(copy_object_impl(pointer),tag);
-}
-
-#define COPY_OBJECT(lvalue) lvalue = copy_object(lvalue)
-
-INLINE void copy_handle(CELL* handle)
 {
 	COPY_OBJECT(*handle);
 }
 
-void collect_roots(void);
+void clear_cards(CELL from, CELL to);
-void collect_card(CARD *ptr);
+void unmark_cards(CELL from, CELL to);
-void collect_gen_cards(CELL gen);
-void collect_cards(void);
-void clear_cards(void);
 void primitive_gc(void);
+void garbage_collection(CELL gen);
 void maybe_garbage_collection(void);
 void primitive_gc_time(void);

native/hashtable.c

@@ -24,5 +24,5 @@ void fixup_hashtable(F_HASHTABLE* hashtable)
 
 void collect_hashtable(F_HASHTABLE* hashtable)
 {
-	COPY_OBJECT(hashtable->array);
+	copy_handle(&hashtable->array);
 }

native/memory.c

@@ -1,26 +1,5 @@
 #include "factor.h"
 
-void dump_generations(void)
-{
-	int i;
-	for(i = 0; i < GC_GENERATIONS; i++)
-	{
-		fprintf(stderr,"Generation %d: base=%lu, size=%lu, here=%lu\n",
-			i,
-			generations[i].base,
-			generations[i].limit - generations[i].base,
-			generations[i].here);
-	}
-
-	fprintf(stderr,"Semispace: base=%lu, size=%lu, here=%lu\n",
-		prior.base,
-		prior.limit - prior.base,
-		prior.here);
-
-	fprintf(stderr,"Cards: base=%lu, size=%lu\n",(CELL)cards,
-		(CELL)(cards_end - cards));
-}
-
 CELL init_zone(ZONE *z, CELL size, CELL base)
 {
 	z->base = z->here = base;
@@ -30,18 +9,24 @@ CELL init_zone(ZONE *z, CELL size, CELL base)
 }
 
 /* input parameters must be 8 byte aligned */
+/* the heap layout is important:
+- two semispaces: tenured and prior
+- younger generations follow */
 void init_arena(CELL young_size, CELL aging_size)
 {
+	int i;
+	CELL alloter;
+
 	CELL total_size = (GC_GENERATIONS - 1) * young_size + 2 * aging_size;
 	CELL cards_size = total_size / CARD_SIZE;
 
 	heap_start = (CELL)alloc_guarded(total_size);
+	heap_end = heap_start + total_size;
+
 	cards = alloc_guarded(cards_size);
 	cards_end = cards + cards_size;
-	clear_cards();
 
-	int i;
+	alloter = heap_start;
-	CELL alloter = heap_start;
 
 	if(heap_start == 0)
 		fatal_error("Cannot allocate data heap",total_size);
@@ -49,9 +34,11 @@ void init_arena(CELL young_size, CELL aging_size)
 	alloter = init_zone(&tenured,aging_size,alloter);
 	alloter = init_zone(&prior,aging_size,alloter);
 
-	for(i = 0; i < GC_GENERATIONS - 1; i++)
+	for(i = GC_GENERATIONS - 2; i >= 0; i--)
 		alloter = init_zone(&generations[i],young_size,alloter);
 
+	clear_cards(TENURED,NURSERY);
+
 	allot_zone = &nursery;
 
 	if(alloter != heap_start + total_size)
@@ -127,7 +114,7 @@ void primitive_size(void)
 
 void primitive_begin_scan(void)
 {
-	primitive_gc();
+	garbage_collection(TENURED);
 	heap_scan_ptr = tenured.base;
 	heap_scan_end = tenured.here;
 	heap_scan = true;

native/memory.h

@@ -58,9 +58,10 @@ ZONE generations[GC_GENERATIONS];
 ZONE *allot_zone;
 
 #define tenured generations[TENURED]
-#define nursery generations[TENURED] /* XXX */
+#define nursery generations[NURSERY]
 
 CELL heap_start;
+CELL heap_end;
 
 /* spare semi-space; rotates with tenured. */
 ZONE prior;
@@ -82,18 +83,23 @@ CARD *cards_end;
 /* A card is 16 bytes (128 bits), 5 address bits per card.
 it is important that 7 bits is sufficient to represent every
 offset within the card */
-#define CARD_SIZE 16
+#define CARD_SIZE 128
-#define CARD_BITS 4
+#define CARD_BITS 7
-#define CARD_MASK (CARD_SIZE-1)
+#define ADDR_CARD_MASK (CARD_SIZE-1)
 
 INLINE CARD card_marked(CARD c)
 {
 	return c & CARD_MARK_MASK;
 }
 
+INLINE void unmark_card(CARD *c)
+{
+	*c &= CARD_BASE_MASK;
+}
+
 INLINE void clear_card(CARD *c)
 {
-	*c = CARD_BASE_MASK;
+	*c = CARD_BASE_MASK; /* invalid value */
 }
 
 INLINE u8 card_base(CARD c)
@@ -101,11 +107,6 @@ INLINE u8 card_base(CARD c)
 	return c & CARD_BASE_MASK;
 }
 
-INLINE void rebase_card(CARD *c, u8 base)
-{
-	*c = base;
-}
-
 #define ADDR_TO_CARD(a) (CARD*)((((CELL)a-heap_start)>>CARD_BITS)+(CELL)cards)
 #define CARD_TO_ADDR(c) (CELL*)((((CELL)c-(CELL)cards)<<CARD_BITS)+heap_start)
 
@@ -122,10 +123,11 @@ INLINE void write_barrier(CELL address)
 /* we need to remember the first object allocated in the card */
 INLINE void allot_barrier(CELL address)
 {
-	CARD *c = ADDR_TO_CARD(address);
+	CARD *ptr = ADDR_TO_CARD(address);
 	/* we need to remember the first object allocated in the
 	card */
-	rebase_card(c,MIN(card_base(*c),(address & CARD_MASK)));
+	CARD c = *ptr;
+	*ptr = (card_marked(c) | MIN(card_base(c),(address & ADDR_CARD_MASK)));
 }
 
 bool allot_profiling;
@@ -134,7 +136,6 @@ bool allot_profiling;
 size must be a multiple of the page size */
 void* alloc_guarded(CELL size);
 
-void dump_generations(void);
 CELL init_zone(ZONE *z, CELL size, CELL base);
 void init_arena(CELL young_size, CELL aging_size);
 void flip_zones();
@@ -146,7 +147,7 @@ INLINE CELL align8(CELL a)
 	return ((a & 7) == 0) ? a : ((a + 8) & ~7);
 }
 
-INLINE void* allot(CELL a)
+INLINE void *allot(CELL a)
 {
 	CELL h = allot_zone->here;
 	allot_barrier(h);

native/relocate.c

@@ -2,8 +2,6 @@
 
 void relocate_object(CELL relocating)
 {
-	allot_barrier(relocating);
-
 	switch(untag_header(get(relocating)))
 	{
 	case WORD_TYPE:
@@ -42,6 +40,8 @@ INLINE CELL relocate_data_next(CELL relocating)
 	CELL size = CELLS;
 	CELL cell = get(relocating);
 
+	allot_barrier(relocating);
+
 	if(headerp(cell))
 	{
 		size = untagged_object_size(relocating);
@@ -136,7 +136,7 @@ INLINE CELL relocate_code_next(CELL relocating)
 		+ compiled->reloc_length);
 
 	if(compiled->header != COMPILED_HEADER)
-		fatal_error("Wrong compiled header",relocating);
+		critical_error("Wrong compiled header",relocating);
 
 	while(rel < rel_end)
 	{
@@ -175,7 +175,7 @@ INLINE CELL relocate_code_next(CELL relocating)
 			code_fixup_16_16((CELL*)rel->offset);
 			break;
 		default:
-			fatal_error("Unsupported rel",rel->type);
+			critical_error("Unsupported rel",rel->type);
 			break;
 		}
 

native/run.h

@@ -1,8 +1,5 @@
 #define USER_ENV 16
 
-#define STDIN_ENV      0
-#define STDOUT_ENV     1
-#define STDERR_ENV     2
 #define NAMESTACK_ENV  3 /* used by library only */
 #define GLOBAL_ENV     4
 #define BREAK_ENV      5
@@ -15,6 +12,7 @@
 #define ERROR_ENV      12 /* a marker consed onto kernel errors */
 #define IN_ENV         13
 #define OUT_ENV        14
+#define GEN_ENV        15 /* set to GC_GENERATIONS constant */
 
 /* Profiling timer */
 #ifndef WIN32

native/sbuf.c

@@ -24,5 +24,5 @@ void fixup_sbuf(F_SBUF* sbuf)
 
 void collect_sbuf(F_SBUF* sbuf)
 {
-	COPY_OBJECT(sbuf->string);
+	copy_handle(&sbuf->string);
 }

native/unix/signal.c

@@ -5,9 +5,7 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 	if(allot_zone->here > allot_zone->limit)
 	{
 		fprintf(stderr,"Out of memory!\n");
-		dump_generations();
+		factorbug();
-		fflush(stderr);
-		exit(1);
 	}
 	else
 		signal_error(signal);
@@ -15,7 +13,7 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 
 void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap)
 {
-	dump_stacks();
+	factorbug();
 }
 
 /* Called from a signal handler. XXX - is this safe? */
@@ -40,12 +38,16 @@ void init_signals(void)
 	struct sigaction profiling_sigaction;
 	struct sigaction ign_sigaction;
 	struct sigaction dump_sigaction;
+	sigemptyset(&custom_sigaction.sa_mask);
 	custom_sigaction.sa_sigaction = signal_handler;
 	custom_sigaction.sa_flags = SA_SIGINFO;
+	sigemptyset(&profiling_sigaction.sa_mask);
 	profiling_sigaction.sa_sigaction = call_profiling_step;
 	profiling_sigaction.sa_flags = SA_SIGINFO;
+	sigemptyset(&dump_sigaction.sa_mask);
 	dump_sigaction.sa_sigaction = dump_stack_signal;
 	dump_sigaction.sa_flags = SA_SIGINFO;
+	sigemptyset(&ign_sigaction.sa_mask);
 	ign_sigaction.sa_handler = SIG_IGN;
 	sigaction(SIGABRT,&custom_sigaction,NULL);
 	sigaction(SIGFPE,&custom_sigaction,NULL);

native/vector.c

@@ -24,5 +24,5 @@ void fixup_vector(F_VECTOR* vector)
 
 void collect_vector(F_VECTOR* vector)
 {
-	COPY_OBJECT(vector->array);
+	copy_handle(&vector->array);
 }

native/word.c

@@ -54,6 +54,6 @@ void fixup_word(F_WORD* word)
 
 void collect_word(F_WORD* word)
 {
-	COPY_OBJECT(word->def);
+	copy_handle(&word->def);
-	COPY_OBJECT(word->props);
+	copy_handle(&word->props);
 }