starting generational GC

Makefile

@@ -1,16 +1,22 @@
 CC = gcc
-DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
+#DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
-#DEFAULT_CFLAGS = -g $(SITE_CFLAGS)
+DEFAULT_CFLAGS = -g
 DEFAULT_LIBS = -lm
 
-STRIP = strip
+#STRIP = strip
+STRIP = touch
 
-UNIX_OBJS = native/unix/file.o native/unix/signal.o \
+UNIX_OBJS = native/unix/file.o \
-	native/unix/ffi.o native/unix/run.o
+	native/unix/signal.o \
+	native/unix/ffi.o \
+	native/unix/run.o \
+	native/unix/memory.o
 
-WIN32_OBJS = native/win32/ffi.o native/win32/file.o \
+WIN32_OBJS = native/win32/ffi.o \
+	native/win32/file.o \
 	native/win32/misc.o \
-	native/win32/run.o
+	native/win32/run.o \
+	native/win32/memory.o
 
 ifdef WIN32
 	PLAF_OBJS = $(WIN32_OBJS)

TODO.FACTOR.txt

@@ -1,6 +1,18 @@
+- faster layout
+- tiled window manager
+- c primitive arrays: or just specialized arrays
+  float, complex, byte, char, cell...
+- generational gc
+- add a socket timeout
+- virtual hosts
+- keep alive
+- sleep word
+- update docs
+- redo new compiler backend for PowerPC
+
+- plugin: supportsBackspace
 - if external factor is down, don't add tons of random shit to the       
   dictionary
-- faster layout
 - SDL_Rect** type
 - get all-tests to run with -no-compile
 - fix i/o on generic x86/ppc unix
@@ -8,6 +20,7 @@
 - 2map slow with lists
 - nappend: instead of using push, enlarge the sequence with set-length
   then add set the elements with set-nth
+- faster sequence operations
 - generic each some? all? memq? all=?  index? subseq? map
 - index and index* are very slow with lists
 - unsafe-sbuf>string
@@ -15,22 +28,16 @@
 - GENERIC: map
   - list impl same as now
 - code walker & exceptions
-- generational gc
 - if two tasks write to a unix stream, the buffer can overflow
 - rename prettyprint to pprint
 - reader syntax for arrays, byte arrays, displaced aliens
-- add a socket timeout
-- virtual hosts
-- keep alive
 - dipping seq-2nmap, seq-2each
 - array sort
-- tiled window manager
-- redo new compiler backend for PowerPC
-- weird bug uncovered during bootstrap stress-test
 - images saved from plugin do not work
 - making an image from plugin hangs
 - generic skip
 - inference needs to be more robust with heavily recursive code
+- investigate orphans
 
 + plugin:
 
@@ -61,6 +68,8 @@
 
 + compiler:
 
+- [ EAX 0 ] --> [ EAX ]
+- intrinsic char-slot set-char-slot integer-slot set-integer-slot
 - optimize the generic word prologue
 - [ [ dup call ] dup call ] infer hangs
 - more accurate types for various words

factor/FactorWord.java

@@ -107,6 +107,14 @@ public class FactorWord extends FactorArtifact implements FactorExternalizable,
 	//{{{ compareTo() method
 	public int compareTo(Object o)
 	{
-		return name.compareTo(((FactorWord)o).name);
+		int c = name.compareTo(((FactorWord)o).name);
+		if(c == 0)
+		{
+			return String.valueOf(vocabulary)
+				.compareTo(String.valueOf(
+				((FactorWord)o).vocabulary));
+		}
+		else
+			return c;
 	} //}}}
 }

library/bootstrap/image.factor

@@ -65,12 +65,20 @@ SYMBOL: boot-quot
     ( relocation base at end of header ) base emit
     ( bootstrap quotation set later ) 0 emit
     ( global namespace set later ) 0 emit
+    ( pointer to t object ) 0 emit
+    ( pointer to bignum 0 ) 0 emit
+    ( pointer to bignum 1 ) 0 emit
+    ( pointer to bignum -1 ) 0 emit
     ( size of heap set later ) 0 emit ;
 
 : boot-quot-offset 3 ;
 : global-offset    4 ;
-: heap-size-offset 5 ;
+: t-offset         5 ;
-: header-size      6 ;
+: 0-offset         6 ;
+: 1-offset         7 ;
+: -1-offset        8 ;
+: heap-size-offset 9 ;
+: header-size      10 ;
 
 GENERIC: ' ( obj -- ptr )
 #! Write an object to the image.
@@ -117,7 +125,8 @@ M: bignum ' ( bignum -- tagged )
 ! Padded with fixnums for 8-byte alignment
 
 : t,
-    object-tag here-as "t" set
+    object-tag here-as
+    dup t-offset fixup "t" set
     t-type >header emit
     0 ' emit ;
 
@@ -126,9 +135,9 @@ M: f ' ( obj -- ptr )
     #! f is #define F RETAG(0,OBJECT_TYPE)
     drop object-tag ;
 
-:  0,  0 >bignum ' drop ;
+:  0,  0 >bignum '  0-offset fixup ;
-:  1,  1 >bignum ' drop ;
+:  1,  1 >bignum '  1-offset fixup ;
-: -1, -1 >bignum ' drop ;
+: -1, -1 >bignum ' -1-offset fixup ;
 
 ( Beginning of the image )
 ! The image begins with the header, then T,

library/test/test.factor

@@ -11,7 +11,7 @@ M: assert error.
     "Got: " write assert-got . ;
 
 : assert= ( a b -- )
-    2dup = [ <assert> throw ] unless ;
+    2dup = [ 2drop ] [ <assert> throw ] ifte ;
 
 : print-test ( input output -- )
     "--> " write 2list . flush ;

native/bignum.c

@@ -207,13 +207,6 @@ void primitive_bignum_not(void)
 		untag_bignum_fast(dpeek()))));
 }
 
-void copy_bignum_constants(void)
-{
-	COPY_OBJECT(bignum_zero);
-	COPY_OBJECT(bignum_pos_one);
-	COPY_OBJECT(bignum_neg_one);
-}
-
 void box_signed_cell(F_FIXNUM integer)
 {
 	dpush(tag_integer(integer));

native/bignum.h

@@ -32,7 +32,6 @@ void primitive_bignum_lesseq(void);
 void primitive_bignum_greater(void);
 void primitive_bignum_greatereq(void);
 void primitive_bignum_not(void);
-void copy_bignum_constants(void);
 
 INLINE CELL tag_integer(F_FIXNUM x)
 {

native/compiler.c

@@ -2,7 +2,10 @@
 
 void init_compiler(CELL size)
 {
-	init_zone(&compiling,size);
+	compiling.base = compiling.here = (CELL)alloc_guarded(size);
+	if(compiling.base == 0)
+		fatal_error("Cannot allocate code heap",size);
+	compiling.limit = compiling.base + size;
 	last_flush = compiling.base;
 }
 

native/factor.c

@@ -1,11 +1,12 @@
 #include "factor.h"
 
 void init_factor(char* image, CELL ds_size, CELL cs_size,
-	CELL data_size, CELL code_size, CELL literal_size)
+	CELL young_size, CELL aging_size,
+	CELL code_size, CELL literal_size)
 {
 	srand((unsigned)time(NULL)); /* initialize random number generator */
 	init_ffi();
-	init_arena(data_size);
+	init_arena(young_size,aging_size);
 	init_compiler(code_size);
 	load_image(image,literal_size);
 	init_stacks(ds_size,cs_size);
@@ -32,7 +33,8 @@ int main(int argc, char** argv)
 {
 	CELL ds_size = 2048;
 	CELL cs_size = 2048;
-	CELL data_size = 16;
+	CELL young_size = 4;
+	CELL aging_size = 8;
 	CELL code_size = 2;
 	CELL literal_size = 64;
 	CELL args;
@@ -44,7 +46,9 @@ int main(int argc, char** argv)
 		printf("Runtime options -- n is a number:\n");
 		printf(" +Dn   Data stack size, kilobytes\n");
 		printf(" +Cn   Call stack size, kilobytes\n");
-		printf(" +Mn   Data heap size, megabytes\n");
+		printf(" +Yn   Size of %d youngest generations, megabytes\n",
+			GC_GENERATIONS-1);
+		printf(" +An   Size of tenured and semi-spaces, megabytes\n");
 		printf(" +Xn   Code heap size, megabytes\n");
 		printf(" +Ln   Literal table size, kilobytes. Only for bootstrapping\n");
 		printf("Other options are handled by the Factor library.\n");
@@ -57,7 +61,8 @@ int main(int argc, char** argv)
 	{
 		if(factor_arg(argv[i],"+D%d",&ds_size)) continue;
 		if(factor_arg(argv[i],"+C%d",&cs_size)) continue;
-		if(factor_arg(argv[i],"+M%d",&data_size)) continue;
+		if(factor_arg(argv[i],"+Y%d",&young_size)) continue;
+		if(factor_arg(argv[i],"+A%d",&aging_size)) continue;
 		if(factor_arg(argv[i],"+X%d",&code_size)) continue;
 		if(factor_arg(argv[i],"+L%d",&literal_size)) continue;
 
@@ -71,7 +76,8 @@ int main(int argc, char** argv)
 	init_factor(argv[1],
 		ds_size * 1024,
 		cs_size * 1024,
-		data_size * 1024 * 1024,
+		young_size * 1024 * 1024,
+		aging_size * 1024 * 1024,
 		code_size * 1024 * 1024,
 		literal_size * 1024);
 

native/gc.c

@@ -1,26 +1,23 @@
 #include "factor.h"
 
-/* Stop-and-copy garbage collection using Cheney's algorithm. */
+/* Generational copying garbage collector */
-
-/* #define GC_DEBUG */
-
-INLINE void gc_debug(char* msg, CELL x) {
-#ifdef GC_DEBUG
-	printf("%s %d\n",msg,x);
-#endif
-}
 
 void collect_roots(void)
 {
 	int i;
-
 	CELL ptr;
 
-	/*T must be the first in the heap */
+	gc_debug("root: t",T);
 	COPY_OBJECT(T);
-	/* the bignum 0 1 -1 constants must be the next three */
+	gc_debug("root: bignum_zero",bignum_zero);
-	copy_bignum_constants();
+	COPY_OBJECT(bignum_zero);
+	gc_debug("root: bignum_pos_one",bignum_pos_one);
+	COPY_OBJECT(bignum_pos_one);
+	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)
@@ -33,6 +30,32 @@ void collect_roots(void)
 		copy_handle(&userenv[i]);
 }
 
+void clear_cards(void)
+{
+	BYTE *ptr;
+	for(ptr = cards; ptr < cards_end; ptr++)
+		clear_card(ptr);
+}
+
+void collect_cards(void)
+{
+	BYTE *ptr;
+	for(ptr = cards; ptr < cards_end; ptr++)
+	{
+		CARD c = *ptr;
+		if(card_marked(*ptr))
+		{
+			CELL offset = (c & CARD_BASE_MASK);
+			if(offset == 0x7f)
+				critical_error("bad card",c);
+			CELL ea = (CELL)CARD_TO_ADDR(c) + offset;
+			printf("write barrier hit %d\n",offset);
+			printf("object header: %x\n",get(ea));
+			clear_card(ptr);
+		}
+	}
+}
+
 /*
 Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 If the object has already been copied, return the forwarding
@@ -43,11 +66,6 @@ CELL copy_object_impl(CELL pointer)
 {
 	CELL newpointer;
 
-#ifdef GC_DEBUG
-	if(in_zone(&active,pointer))
-		critical_error("copy_object given newspace ptr",pointer);
-#endif
-
 	gc_debug("copy_object",pointer);
 	newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
 		object_size(pointer));
@@ -120,7 +138,10 @@ void primitive_gc(void)
 
 	flip_zones();
 	scan = active.base;
+
 	collect_roots();
+	collect_cards();
+
 	/* collect literal objects referenced from compiled code */
 	collect_literals();
 	

native/gc.h

@@ -16,12 +16,22 @@ INLINE void* copy_untagged_object(void* pointer, CELL size)
 
 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);
+#endif
+}
+
 INLINE CELL copy_object(CELL pointer)
 {
 	CELL tag;
 	CELL header;
 	CELL untagged;
 
+	gc_debug("copy object",pointer);
+
 	if(pointer == F)
 		return F;
 
@@ -33,7 +43,10 @@ INLINE CELL copy_object(CELL pointer)
 	header = get(UNTAG(pointer));
 	untagged = UNTAG(header);
 	if(TAG(header) != FIXNUM_TYPE && in_zone(&active,untagged))
+	{
+		gc_debug("forwarding",untagged);
 		return RETAG(untagged,tag);
+	}
 	else
 		return RETAG(copy_object_impl(pointer),tag);
 }
@@ -46,6 +59,8 @@ INLINE void copy_handle(CELL* handle)
 }
 
 void collect_roots(void);
+void collect_cards(void);
+void clear_cards(void);
 void primitive_gc(void);
 void maybe_garbage_collection(void);
 void primitive_gc_time(void);

native/image.c

@@ -1,5 +1,21 @@
 #include "factor.h"
 
+void init_objects(HEADER *h)
+{
+	int i;
+	for(i = 0; i < USER_ENV; i++)
+		userenv[i] = F;
+	profile_depth = 0;
+	executing = F;
+
+	userenv[GLOBAL_ENV] = h->global;
+	userenv[BOOT_ENV] = h->boot;
+	T = h->t;
+	bignum_zero = h->bignum_zero;
+	bignum_pos_one = h->bignum_pos_one;
+	bignum_neg_one = h->bignum_neg_one;
+}
+
 void load_image(char* filename, int literal_table)
 {
 	FILE* file;
@@ -67,10 +83,7 @@ void load_image(char* filename, int literal_table)
 	printf(" relocating...");
 	fflush(stdout);
 
-	clear_environment();
+	init_objects(&h);
-
-	userenv[GLOBAL_ENV] = h.global;
-	userenv[BOOT_ENV] = h.boot;
 
 	relocate_data();
 	relocate_code();
@@ -97,6 +110,10 @@ bool save_image(char* filename)
 	h.boot = userenv[BOOT_ENV];
 	h.size = active.here - active.base;
 	h.global = userenv[GLOBAL_ENV];
+	h.t = T;
+	h.bignum_zero = bignum_zero;
+	h.bignum_pos_one = bignum_pos_one;
+	h.bignum_neg_one = bignum_neg_one;
 	fwrite(&h,sizeof(HEADER),1,file);
 
 	ext_h.size = compiling.here - compiling.base;

native/image.h

@@ -12,6 +12,14 @@ typedef struct {
 	CELL boot;
 	/* tagged pointer to global namespace */
 	CELL global;
+	/* tagged pointer to t singleton */
+	CELL t;
+	/* tagged pointer to bignum 0 */
+	CELL bignum_zero;
+	/* tagged pointer to bignum 1 */
+	CELL bignum_pos_one;
+	/* tagged pointer to bignum -1 */
+	CELL bignum_neg_one;
 	/* size of heap */
 	CELL size;
 } HEADER;
@@ -28,6 +36,7 @@ typedef struct EXT_HEADER {
 	CELL literal_max;
 } HEADER_2;
 
+void init_objects(HEADER *h);
 void load_image(char* file, int literal_size);
 bool save_image(char* file);
 void primitive_save_image(void);

native/memory.c

@@ -1,64 +1,65 @@
 #include "factor.h"
 
-/* set up guard pages to check for under/overflow.
+void dump_generations(void)
-size must be a multiple of the page size */
-
-#ifdef WIN32
-void *alloc_guarded(CELL size)
 {
-       SYSTEM_INFO si;
+	int i;
-       char *mem;
+	for(i = 0; i < GC_GENERATIONS; i++)
-       DWORD ignore;
+	{
+		fprintf(stderr,"Generation %d: base=%d, size=%d, here=%d\n",
+			i,
+			generations[i].base,
+			generations[i].limit - generations[i].base,
+			generations[i].here);
+	}
 
-       GetSystemInfo(&si);
+	fprintf(stderr,"Semispace: base=%d, size=%d, here=%d\n",
-       mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
+		prior.base,
+		prior.limit - prior.base,
+		prior.here);
 
-       if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
+	fprintf(stderr,"Cards: base=%d, size=%d\n",cards,cards_end - cards);
-	       fatal_error("Cannot allocate low guard page", (CELL)mem);
-
-       if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
-	       fatal_error("Cannot allocate high guard page", (CELL)mem);
-
-       return mem + si.dwPageSize;
 }
-#else
+
-void* alloc_guarded(CELL size)
+CELL init_zone(ZONE *z, CELL size, CELL base)
 {
-	int pagesize = getpagesize();
+	z->base = z->here = base;
-
-	char* array = mmap((void*)0,pagesize + size + pagesize,
-		PROT_READ | PROT_WRITE | PROT_EXEC,
-		MAP_ANON | MAP_PRIVATE,-1,0);
-
-	if(mprotect(array,pagesize,PROT_NONE) == -1)
-		fatal_error("Cannot allocate low guard page",(CELL)array);
-
-	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
-		fatal_error("Cannot allocate high guard page",(CELL)array);
-
-	/* return bottom of actual array */
-	return array + pagesize;
-}
-#endif
-
-void init_zone(ZONE* z, CELL size)
-{
-	z->base = z->here = align8((CELL)alloc_guarded(size));
-	if(z->base == 0)
-		fatal_error("Cannot allocate zone",size);
 	z->limit = z->base + size;
 	z->alarm = z->base + (size * 3) / 4;
-	z->base = align8(z->base);
+	return z->limit;
 }
 
-void init_arena(CELL size)
+/* input parameters must be 8 byte aligned */
+void init_arena(CELL young_size, CELL aging_size)
 {
-	init_zone(&active,size);
+	CELL total_size = (GC_GENERATIONS - 1) * young_size + 2 * aging_size;
-	init_zone(&prior,size);
+	CELL cards_size = total_size / CARD_SIZE;
+
+	heap_start = (CELL)alloc_guarded(total_size);
+	cards = alloc_guarded(cards_size);
+	cards_end = cards + cards_size;
+	clear_cards();
+
+	int i;
+	CELL alloter = heap_start;
+
+	if(heap_start == 0)
+		fatal_error("Cannot allocate data heap",total_size);
+
+	alloter = init_zone(&generations[TENURED],aging_size,alloter);
+	alloter = init_zone(&prior,aging_size,alloter);
+
+	for(i = 0; i < GC_GENERATIONS - 1; i++)
+		alloter = init_zone(&generations[i],young_size,alloter);
+
+	if(alloter != heap_start + total_size)
+		fatal_error("Oops",alloter);
+
 	allot_profiling = false;
 	gc_in_progress = false;
 	heap_scan = false;
 	gc_time = 0;
+	
+	dump_generations();
 }
 
 void allot_profile_step(CELL a)
@@ -90,11 +91,6 @@ void flip_zones()
 	active.here = active.base;
 }
 
-bool in_zone(ZONE* z, CELL pointer)
-{
-	return pointer >= z->base && pointer < z->limit;
-}
-
 void primitive_room(void)
 {
 	box_signed_cell(compiling.limit - compiling.here);

native/memory.h

@@ -1,36 +1,5 @@
-typedef struct {
+/* macros for reading/writing memory, useful when working around
-	CELL base;
+C's type system */
-	CELL here;
-	CELL alarm;
-	CELL limit;
-} ZONE;
-
-ZONE active;
-ZONE prior;
-
-bool allot_profiling;
-
-void* alloc_guarded(CELL size);
-void init_zone(ZONE* zone, CELL size);
-void init_arena(CELL size);
-void flip_zones();
-
-void allot_profile_step(CELL a);
-
-INLINE CELL align8(CELL a)
-{
-	return ((a & 7) == 0) ? a : ((a + 8) & ~7);
-}
-
-INLINE void* allot(CELL a)
-{
-	CELL h = active.here;
-	active.here += align8(a);
-	if(allot_profiling)
-		allot_profile_step(align8(a));
-	return (void*)h;
-}
-
 INLINE CELL get(CELL where)
 {
 	return *((CELL*)where);
@@ -61,6 +30,130 @@ INLINE void bput(CELL where, BYTE what)
 	*((BYTE*)where) = what;
 }
 
+/* generational copying GC divides memory into zones */
+typedef struct {
+	/* start of zone */
+	CELL base;
+	/* allocation pointer */
+	CELL here;
+	/* only for nursery: when it gets this full, call GC */
+	CELL alarm;
+	/* end of zone */
+	CELL limit;
+} ZONE;
+
+INLINE bool in_zone(ZONE* z, CELL pointer)
+{
+	return pointer >= z->base && pointer < z->limit;
+}
+
+/* total number of generations. */
+#define GC_GENERATIONS 3
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* the oldest generation */
+#define TENURED (GC_GENERATIONS-1)
+
+ZONE generations[GC_GENERATIONS];
+
+CELL heap_start;
+
+#define active generations[TENURED]
+
+/* spare semi-space; rotates with generations[TENURED]. */
+ZONE prior;
+
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator.
+*/
+#define CARD_MARK_MASK 0x80
+#define CARD_BASE_MASK 0x7f
+typedef u8 CARD;
+CARD *cards;
+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_BITS 4
+#define CARD_MASK CARD_SIZE-1
+
+INLINE CARD card_marked(CARD c)
+{
+	return c & CARD_MARK_MASK;
+}
+
+INLINE void clear_card(CARD *c)
+{
+	*c = CARD_BASE_MASK;
+}
+
+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*)(((a-heap_start)>>CARD_BITS)+(CELL)cards)
+#define CARD_TO_ADDR(c) (CELL*)(((c-(CELL)cards)<<CARD_BITS)+heap_start)
+
+/* this is an inefficient write barrier. compiled definitions use a more
+efficient one hand-coded in assembly. the write barrier must be called
+any time we are potentially storing a pointer from an older generation
+to a younger one */
+INLINE void write_barrier(CELL address)
+{
+	CARD *c = ADDR_TO_CARD(address);
+	*c |= CARD_MARK_MASK;
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+	CARD *c = 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));
+}
+
+bool allot_profiling;
+
+/* set up guard pages to check for under/overflow.
+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();
+
+void allot_profile_step(CELL a);
+
+INLINE CELL align8(CELL a)
+{
+	return ((a & 7) == 0) ? a : ((a + 8) & ~7);
+}
+
+INLINE void* allot(CELL a)
+{
+	CELL h = active.here;
+	allot_barrier(h);
+	active.here += align8(a);
+	if(allot_profiling)
+		allot_profile_step(align8(a));
+	return (void*)h;
+}
+
 bool in_zone(ZONE* z, CELL pointer);
 
 void primitive_room(void);

native/relocate.c

@@ -2,6 +2,8 @@
 
 void relocate_object(CELL relocating)
 {
+	allot_barrier(relocating);
+
 	switch(untag_header(get(relocating)))
 	{
 	case WORD_TYPE:
@@ -51,28 +53,20 @@ INLINE CELL relocate_data_next(CELL relocating)
 	return relocating + size;
 }
 
-INLINE CELL init_object(CELL relocating, CELL* handle, CELL type)
-{
-	if(untag_header(get(relocating)) != type)
-		fatal_error("init_object() failed",get(relocating));
-	*handle = tag_object((CELL*)relocating);
-	return relocate_data_next(relocating);
-}
-
 void relocate_data()
 {
 	CELL relocating = active.base;
 
 	data_fixup(&userenv[BOOT_ENV]);
 	data_fixup(&userenv[GLOBAL_ENV]);
-
+	printf("%d\n",T);
-	/* The first object in the image must always T */
+	printf("%d\n",bignum_zero);
-	relocating = init_object(relocating,&T,T_TYPE);
+	printf("%d\n",bignum_pos_one);
-
+	printf("%d\n",bignum_neg_one);
-	/* The next three must be bignum 0, 1, -1  */
+	data_fixup(&T);
-	relocating = init_object(relocating,&bignum_zero,BIGNUM_TYPE);
+	data_fixup(&bignum_zero);
-	relocating = init_object(relocating,&bignum_pos_one,BIGNUM_TYPE);
+	data_fixup(&bignum_pos_one);
-	relocating = init_object(relocating,&bignum_neg_one,BIGNUM_TYPE);
+	data_fixup(&bignum_neg_one);
 
 	for(;;)
 	{

native/run.c

@@ -1,14 +1,5 @@
 #include "factor.h"
 
-void clear_environment(void)
-{
-	int i;
-	for(i = 0; i < USER_ENV; i++)
-		userenv[i] = F;
-	profile_depth = 0;
-	executing = F;
-}
-
 INLINE void execute(F_WORD* word)
 {
 	((XT)(word->xt))(word);

native/run.h

@@ -85,8 +85,6 @@ INLINE void call(CELL quot)
 	callframe = quot;
 }
 
-void clear_environment(void);
-
 void run(void);
 void platform_run(void);
 void undefined(F_WORD* word);

native/types.c

@@ -96,34 +96,35 @@ void primitive_type(void)
 	drepl(tag_fixnum(type_of(dpeek())));
 }
 
-#define SLOT(obj,slot) UNTAG(obj) + slot * CELLS
+#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
 
 void primitive_slot(void)
 {
 	F_FIXNUM slot = untag_fixnum_fast(dpop());
-	CELL obj = dpop();
+	CELL obj = UNTAG(dpop());
 	dpush(get(SLOT(obj,slot)));
 }
 
 void primitive_set_slot(void)
 {
 	F_FIXNUM slot = untag_fixnum_fast(dpop());
-	CELL obj = dpop();
+	CELL obj = UNTAG(dpop());
 	CELL value = dpop();
 	put(SLOT(obj,slot),value);
+	write_barrier(obj);
 }
 
 void primitive_integer_slot(void)
 {
 	F_FIXNUM slot = untag_fixnum_fast(dpop());
-	CELL obj = dpop();
+	CELL obj = UNTAG(dpop());
 	dpush(tag_integer(get(SLOT(obj,slot))));
 }
 
 void primitive_set_integer_slot(void)
 {
 	F_FIXNUM slot = untag_fixnum_fast(dpop());
-	CELL obj = dpop();
+	CELL obj = UNTAG(dpop());
 	F_FIXNUM value = to_fixnum(dpop());
 	put(SLOT(obj,slot),value);
 }

native/unix/memory.c

@@ -0,0 +1,19 @@
+#include "../factor.h"
+
+void *alloc_guarded(CELL size)
+{
+	int pagesize = getpagesize();
+
+	char* array = mmap((void*)0,pagesize + size + pagesize,
+		PROT_READ | PROT_WRITE | PROT_EXEC,
+		MAP_ANON | MAP_PRIVATE,-1,0);
+
+	if(mprotect(array,pagesize,PROT_NONE) == -1)
+		fatal_error("Cannot allocate low guard page",(CELL)array);
+
+	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
+		fatal_error("Cannot allocate high guard page",(CELL)array);
+
+	/* return bottom of actual array */
+	return array + pagesize;
+}

native/win32/memory.c

@@ -0,0 +1,19 @@
+#include "../factor.h"
+
+void *alloc_guarded(CELL size)
+{
+       SYSTEM_INFO si;
+       char *mem;
+       DWORD ignore;
+
+       GetSystemInfo(&si);
+       mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
+
+       if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
+	       fatal_error("Cannot allocate low guard page", (CELL)mem);
+
+       if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
+	       fatal_error("Cannot allocate high guard page", (CELL)mem);
+
+       return mem + si.dwPageSize;
+}