generational gc and compiler relocation fixes

TODO.FACTOR.txt

@@ -6,6 +6,10 @@
 <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
 
+- simplifier:
+  - dead loads not optimized out
+  - kill tag-fixnum/untag-fixnum
+- \ foo where foo is parsing is not printed readably
 - faster layout
 - tiled window manager
 - c primitive arrays: or just specialized arrays
@@ -17,6 +21,8 @@
 - sleep word
 - update docs
 - redo new compiler backend for PowerPC
+- type predicates: : foo? type 7 eq? ;
+- remove 'not' word, and move t?/f? to kernel
 
 - plugin: supportsBackspace
 - if external factor is down, don't add tons of random shit to the       

library/compiler/compiler.factor

@@ -13,7 +13,7 @@ kernel lists namespaces prettyprint stdio words ;
 
 : compiling ( word -- word parameter )
     check-architecture
-    "Compiling " write dup . flush
+    "Compiling " write dup word. terpri flush
     dup word-def ;
 
 GENERIC: (compile) ( word -- )
@@ -43,7 +43,7 @@ M: compound (compile) ( word -- )
     "compile" get [ word compile ] when ; parsing
 
 : cannot-compile ( word error -- )
-    "Cannot compile " write swap . print-error ;
+    "Cannot compile " write swap word. terpri print-error ;
 
 : try-compile ( word -- )
     [ compile ] [ [ cannot-compile ] when* ] catch ;
@@ -52,7 +52,7 @@ M: compound (compile) ( word -- )
 
 : decompile ( word -- )
     dup compiled? [
-        "Decompiling " write dup . flush
+        "Decompiling " write dup word. terpri flush
         [ word-primitive ] keep set-word-primitive
     ] [
         drop

library/compiler/ppc/alien.factor

@@ -5,7 +5,7 @@ USING: alien compiler inference kernel kernel-internals lists
 math memory namespaces words ;
 
 \ alien-invoke [
-    uncons load-library 2dup rel-dlsym-16/16 dlsym compile-call-far
+    uncons load-library 2dup 1 rel-dlsym dlsym compile-call-far
 ] "generator" set-word-prop
 
 : stack-size 8 + 16 align ;
@@ -16,7 +16,7 @@ math memory namespaces words ;
 ] "generator" set-word-prop
 
 #unbox [
-    uncons f 2dup rel-dlsym-16/16 dlsym compile-call-far
+    uncons f 2dup 1 rel-dlsym dlsym compile-call-far
     3 1 rot stack@ STW
 ] "generator" set-word-prop
 
@@ -25,7 +25,7 @@ math memory namespaces words ;
 ] "generator" set-word-prop
 
 #box [
-    f 2dup rel-dlsym-16/16 dlsym compile-call-far
+    f 2dup 1 rel-dlsym dlsym compile-call-far
 ] "generator" set-word-prop
 
 #cleanup [

library/compiler/ppc/generator.factor

@@ -46,14 +46,14 @@ words ;
 
 : compile-call-label ( label -- )
     dup primitive? [
-        dup rel-primitive-16/16 word-xt compile-call-far
+        dup 1 rel-primitive word-xt compile-call-far
     ] [
         0 BL relative-24
     ] ifte ;
 
 #call-label [
     ! Hack: length of instruction sequence that follows
-    rel-address-16/16  compiled-offset 20 + 18 LOAD32
+    0 1 rel-address  compiled-offset 20 + 18 LOAD32
     1 1 -16 STWU
     18 1 20 STW
     0 B relative-24
@@ -66,7 +66,7 @@ words ;
 
 : compile-jump-label ( label -- )
     dup primitive? [
-        dup rel-primitive-16/16 word-xt compile-jump-far
+        dup 1 rel-primitive word-xt compile-jump-far
     ] [
         0 B relative-24
     ] ifte ;
@@ -94,7 +94,7 @@ words ;
     18 18 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    rel-address-16/16  compiled-offset 24 + 19 LOAD32
+    0 1 rel-address  compiled-offset 24 + 19 LOAD32
     18 18 19 ADD
     18 18 0 LWZ
     18 MTLR

library/compiler/relocate.factor

@@ -11,34 +11,20 @@ SYMBOL: relocation-table
 
 : relocating compiled-offset cell - rel, ;
 
-: rel-primitive ( word rel/abs -- )
+: rel-type, ( rel/abs 16/16 type -- )
-    #! If flag is true; relative.
+    swap 8 shift bitor swap 16 shift bitor rel, ;
-    0 1 ? rel, relocating word-primitive rel, ;
 
-: rel-dlsym ( name dll rel/abs -- )
+: rel-primitive ( word relative 16/16 -- )
-    #! If flag is true; relative.
+    0 rel-type, relocating word-primitive rel, ;
-    2 3 ? rel, relocating cons intern-literal rel, ;
 
-: rel-address ( rel/abs -- )
+: rel-dlsym ( name dll rel/abs 16/16 -- )
+    1 rel-type, relocating cons intern-literal rel, ;
+
+: rel-address ( rel/abs 16/16 -- )
     #! Relocate address just compiled. If flag is true,
     #! relative, and there is nothing to do.
-    [ 4 rel, relocating 0 rel, ] unless ;
+    over [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
 
-: rel-word ( word rel/abs -- )
+: rel-word ( word rel/abs 16/16 -- )
     #! If flag is true; relative.
     over primitive? [ rel-primitive ] [ nip rel-address ] ifte ;
-
-! PowerPC relocations
-
-: rel-primitive-16/16 ( word -- )
-    #! This is called before a sequence like
-    #! 19 LOAD32
-    #! 19 MTCTR
-    #! BCTR
-    5 rel, compiled-offset rel, word-primitive rel, ;
-
-: rel-dlsym-16/16 ( name dll -- )
-    6 rel, compiled-offset rel, cons intern-literal rel, ;
-
-: rel-address-16/16 ( -- )
-    7 rel, compiled-offset rel, 0 rel, ;

library/compiler/x86/generator.factor

@@ -15,7 +15,7 @@ M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
 M: %prologue generate-node drop ;
 
 : compile-c-call ( symbol dll -- )
-    2dup dlsym CALL t rel-dlsym ;
+    2dup dlsym CALL 1 0 rel-dlsym ;
 
 M: %call generate-node ( vop -- )
     vop-label dup postpone-word CALL ;
@@ -58,7 +58,7 @@ M: %dispatch generate-node ( vop -- )
     ! Multiply by 4 to get a jump table offset
     dup 2 SHL
     ! Add to jump table base
-    dup HEX: ffff ADD  just-compiled >r f rel-address
+    dup HEX: ffff ADD  just-compiled >r 0 0 rel-address
     ! Jump to jump table entry
     unit JMP
     ! Align for better performance

library/compiler/x86/stack.factor

@@ -7,7 +7,7 @@ memory sequences words ;
 : rel-cs ( -- )
     #! Add an entry to the relocation table for the 32-bit
     #! immediate just compiled.
-    "cs" f f rel-dlsym ;
+    "cs" f 0 0 rel-dlsym ;
 
 : CS ( -- [ address ] ) "cs" f dlsym unit ;
 : CS> ( register -- ) CS MOV rel-cs ;
@@ -34,7 +34,7 @@ M: %immediate-d generate-node ( vop -- )
     vop-literal [ ESI ] swap address MOV ;
 
 : load-indirect ( dest literal -- )
-    intern-literal unit MOV f rel-address ;
+    intern-literal unit MOV 0 0 rel-address ;
 
 M: %indirect generate-node ( vop -- )
     #! indirect load of a literal through a table

library/compiler/xt.factor

@@ -49,7 +49,7 @@ TUPLE: relative word where to ;
 : just-compiled compiled-offset 4 - ;
 
 C: relative ( word -- )
-    over t rel-word
+    over 1 0 rel-word
     [ set-relative-word ] keep
     [ just-compiled swap set-relative-where ] keep
     [ compiled-offset swap set-relative-to ] keep ;
@@ -71,7 +71,7 @@ C: absolute ( word -- )
     [ just-compiled swap set-absolute-where ] keep ;
 
 : absolute ( word -- )
-    dup f rel-word <absolute> deferred-xt ;
+    dup 0 0 rel-word <absolute> deferred-xt ;
 
 : >absolute dup absolute-word compiled-xt swap absolute-where ;
 

library/generic/tuple.factor

@@ -16,7 +16,7 @@ hashtables errors sequences vectors ;
     #! Internal allocation function. Do not call it directly,
     #! since you can fool the runtime and corrupt memory by
     #! specifying an incorrect size.
-    <tuple> [ 0 swap set-array-nth ] keep ;
+    <tuple> [ 2 set-slot ] keep ;
 
 : class-tuple 2 slot ; inline
 

library/test/benchmark/fib.factor

@@ -4,6 +4,10 @@ USE: kernel
 USE: math
 USE: test
 USE: math-internals
+USE: namespaces
+
+! Four fibonacci implementations, each one slower than the
+! previous.
 
 : fixnum-fib ( n -- nth fibonacci number )
     dup 1 fixnum<= [
@@ -36,3 +40,18 @@ TUPLE: box i ;
     ] ifte ; compiled
 
 [ << box f 9227465 >> ] [ << box f 34 >> tuple-fib ] unit-test
+
+SYMBOL: n
+: namespace-fib ( n -- n )
+    [
+        n set
+        n get 1 <= [
+            1
+        ] [
+            n get 1 - namespace-fib
+            n get 2 - namespace-fib
+            +
+        ] ifte
+    ] with-scope ; compiled
+
+[ 9227465 ] [ 34 namespace-fib ] unit-test

library/test/test.factor

@@ -87,7 +87,7 @@ SYMBOL: failures
             "buffer" ,
         ] when
         
-        cpu "unknown" = "compile" get and [
+        cpu "unknown" = not "compile" get and [
             [
                 "io/buffer" "compiler/optimizer"
                 "compiler/simple"
@@ -95,7 +95,7 @@ SYMBOL: failures
                 "compiler/generic" "compiler/bail-out"
                 "compiler/linearizer" "compiler/intrinsics"
             ] %
-        ] unless
+        ] when
         
         [
             "benchmark/empty-loop" "benchmark/fac"

native/cards.c

@@ -18,6 +18,8 @@ INLINE void collect_card(CARD *ptr, CELL here)
 
 	while(card_scan < card_end && card_scan < here)
 		card_scan = collect_next(card_scan);
+	
+	cards_scanned++;
 }
 
 INLINE void collect_gen_cards(CELL gen)
@@ -48,8 +50,9 @@ void unmark_cards(CELL from, CELL to)
 
 void clear_cards(CELL from, CELL to)
 {
-	CARD *ptr = ADDR_TO_CARD(generations[from].base);
+	/* NOTE: reverse order due to heap layout. */
-	CARD *last_card = ADDR_TO_CARD(generations[to].limit);
+	CARD *last_card = ADDR_TO_CARD(generations[from].limit);
+	CARD *ptr = ADDR_TO_CARD(generations[to].base);
 	for(; ptr < last_card; ptr++)
 		clear_card(ptr);
 }

native/debug.c

@@ -274,10 +274,10 @@ void factorbug(void)
 		else if(strcmp(cmd,"i") == 0)
 		{
 			fprintf(stderr,"Call frame:\n");
-			dump_cell(callframe);
+			print_obj(callframe);
 			fprintf(stderr,"\n");
 			fprintf(stderr,"Executing:\n");
-			dump_cell(executing);
+			print_obj(executing);
 			fprintf(stderr,"\n");
 		}
 		else if(strcmp(cmd,"e") == 0)

native/gc.c

@@ -44,7 +44,7 @@ void init_arena(CELL young_size, CELL aging_size)
 	for(i = GC_GENERATIONS - 2; i >= 0; i--)
 		alloter = init_zone(&generations[i],young_size,alloter);
 
-	clear_cards(TENURED,NURSERY);
+	clear_cards(NURSERY,TENURED);
 
 	if(alloter != heap_start + total_size)
 		fatal_error("Oops",alloter);
@@ -52,6 +52,8 @@ void init_arena(CELL young_size, CELL aging_size)
 	allot_profiling = false;
 	heap_scan = false;
 	gc_time = 0;
+	minor_collections = 0;
+	cards_scanned = 0;
 }
 
 void collect_roots(void)
@@ -78,18 +80,6 @@ void collect_roots(void)
 		copy_handle(&userenv[i]);
 }
 
-/* follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
-	CELL header = get(untagged);
-	/* another forwarding pointer */
-	if(TAG(header) == GC_COLLECTED)
-		return resolve_forwarding(UNTAG(header),tag);
-	/* we've found the destination */
-	else
-		return RETAG(untagged,tag);
-}
-
 /* Given a pointer to oldspace, copy it to newspace. */
 INLINE void *copy_untagged_object(void *pointer, CELL size)
 {
@@ -103,12 +93,7 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
 
 INLINE CELL copy_object_impl(CELL pointer)
 {
-	CELL newpointer;
+	CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
-
-	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 */
@@ -117,6 +102,23 @@ INLINE CELL copy_object_impl(CELL pointer)
 	return newpointer;
 }
 
+/* follow a chain of forwarding pointers */
+CELL resolve_forwarding(CELL untagged, CELL tag)
+{
+	CELL header = get(untagged);
+	/* another forwarding pointer */
+	if(TAG(header) == GC_COLLECTED)
+		return resolve_forwarding(UNTAG(header),tag);
+	/* we've found the destination */
+	else
+	{
+		CELL pointer = RETAG(untagged,tag);
+		if(should_copy(untagged))
+			pointer = RETAG(copy_object_impl(pointer),tag);
+		return pointer;
+	}
+}
+
 /*
 Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 If the object has already been copied, return the forwarding
@@ -202,7 +204,8 @@ void reset_generations(CELL from, CELL to)
 
 void begin_gc(CELL gen)
 {
-	collecting_generation = generations[gen].base;
+	collecting_gen = gen;
+	collecting_gen_start = generations[gen].base;
 
 	if(gen == TENURED)
 	{
@@ -234,7 +237,12 @@ void end_gc(CELL gen)
 		unmark_cards(TENURED,TENURED);
 		/* all generations except tenured space are
 		now empty */
-		reset_generations(TENURED - 1,NURSERY);
+		reset_generations(NURSERY,TENURED - 1);
+
+		fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
+			minor_collections,cards_scanned);
+		minor_collections = 0;
+		cards_scanned = 0;
 	}
 	else
 	{
@@ -245,7 +253,9 @@ void end_gc(CELL gen)
 		unmark_cards(gen + 1,gen + 1);
 		/* all generations up to and including the one
 		collected are now empty */
-		reset_generations(gen,NURSERY);
+		reset_generations(NURSERY,gen);
+		
+		minor_collections++;
 	}
 }
 
@@ -308,7 +318,18 @@ are also reachable via the GC roots. */
 void maybe_garbage_collection(void)
 {
 	if(nursery.here > nursery.alarm)
-		garbage_collection(NURSERY);
+	{
+		CELL gen = NURSERY;
+		while(gen < TENURED)
+		{
+			ZONE *z = &generations[gen + 1];
+			if(z->here < z->alarm)
+				break;
+			gen++;
+		}
+
+		garbage_collection(gen);
+	}
 }
 
 void primitive_gc_time(void)

native/gc.h

@@ -37,16 +37,20 @@ CELL init_zone(ZONE *z, CELL size, CELL base);
 
 void init_arena(CELL young_size, CELL aging_size);
 
+/* statistics */
 s64 gc_time;
+CELL minor_collections;
+CELL cards_scanned;
 
 /* only meaningful during a GC */
-CELL collecting_generation;
+CELL collecting_gen;
+CELL collecting_gen_start;
 
 /* test if the pointer is in generation being collected, or a younger one.
 init_arena() arranges things so that the older generations are first,
 so we have to check that the pointer occurs after the beginning of
 the requested generation. */
-#define COLLECTING_GEN(ptr) (collecting_generation <= ptr)
+#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
 
 /* #define GC_DEBUG */
 
@@ -56,6 +60,14 @@ INLINE void gc_debug(char* msg, CELL x) {
 #endif
 }
 
+INLINE bool should_copy(CELL untagged)
+{
+	if(collecting_gen == TENURED)
+		return !in_zone(newspace,untagged);
+	else
+		return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
+}
+
 CELL copy_object(CELL pointer);
 #define COPY_OBJECT(lvalue) if(COLLECTING_GEN(lvalue)) lvalue = copy_object(lvalue)
 

native/relocate.c

@@ -40,8 +40,6 @@ 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);
@@ -69,6 +67,7 @@ void relocate_data()
 		if(relocating >= tenured.here)
 			break;
 
+		allot_barrier(relocating);
 		relocating = relocate_data_next(relocating);
 	}
 
@@ -93,7 +92,7 @@ CELL get_rel_symbol(F_REL* rel)
 
 INLINE CELL compute_code_rel(F_REL *rel, CELL original)
 {
-	switch(rel->type)
+	switch(REL_TYPE(rel))
 	{
 	case F_PRIMITIVE:
 		return primitive_to_xt(rel->argument);
@@ -133,7 +132,7 @@ INLINE CELL relocate_code_next(CELL relocating)
 		CELL original;
 		CELL new_value;
 
-		if(rel->risc16_16)
+		if(REL_16_16(rel))
 			original = reloc_get_16_16(rel->offset);
 		else
 			original = get(rel->offset);
@@ -143,10 +142,10 @@ INLINE CELL relocate_code_next(CELL relocating)
 		code_fixup(&rel->offset);
 		new_value = compute_code_rel(rel,original);
 
-		if(rel->relative)
+		if(REL_RELATIVE(rel))
 			new_value -= (rel->offset + CELLS);
 
-		if(rel->risc16_16)
+		if(REL_16_16(rel))
 			reloc_set_16_16(rel->offset,new_value);
 		else
 			put(rel->offset,new_value);

native/relocate.h

@@ -21,13 +21,17 @@ typedef enum {
 	F_CARDS
 } F_RELTYPE;
 
+/* the rel type is built like a cell to avoid endian-specific code in
+the compiler */
+#define REL_TYPE(r) ((r)->type & 0xff)
+/* on PowerPC, some values are stored in the high 16 bits of a pair
+of consecutive cells */
+#define REL_16_16(r) ((r)->type & 0xff00)
+#define REL_RELATIVE(r) ((r)->type & 0xff0000)
+
 /* code relocation consists of a table of entries for each fixup */
 typedef struct {
-	u8 type;
+	CELL type;
-	u8 relative;
-	/* on PowerPC, some values are stored in the high 16 bits of a pair
-	of consecutive cells */
-	u8 risc16_16;
 	CELL offset;
 	CELL argument;
 } F_REL;