memory management change, allocating primitives call gc directly

Makefile

@@ -1,5 +1,5 @@
 CC = gcc
-DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer
+DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer $(SITE_CFLAGS)
 DEFAULT_LIBS = -lm
 
 STRIP = strip
@@ -22,6 +22,7 @@ default:
 	@echo "Run 'make' with one of the following parameters:"
 	@echo ""
 	@echo "bsd"
+	@echo "bsd-nopthread - on FreeBSD 4, if you want to use profiling"
 	@echo "linux"
 	@echo "solaris"
 	@echo ""
@@ -36,6 +37,11 @@ bsd:
 		CFLAGS="$(DEFAULT_CFLAGS) -DFFI -pthread" \
 		LIBS="$(DEFAULT_LIBS)"
 
+bsd-nopthread:
+	$(MAKE) f \
+		CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
+		LIBS="$(DEFAULT_LIBS)"
+
 linux:
 	$(MAKE) f \
 		CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \

library/cross-compiler.factor

@@ -74,7 +74,6 @@ DEFER: os-env
 DEFER: type
 DEFER: size
 DEFER: address
-DEFER: dump
 DEFER: heap-stats
 
 IN: strings
@@ -357,7 +356,6 @@ IN: image
         (random-int)
         type
         size
-        dump
         cwd
         cd
         compiled-offset

library/platform/native/primitives.factor

@@ -209,7 +209,6 @@ USE: words
     [ allot-profiling        | " depth -- " ]
     [ allot-count            | " word -- n " ]
     [ set-allot-count        | " n word -- n " ]
-    [ dump                   | " obj -- " ]
     [ cwd                    | " -- dir " ]
     [ cd                     | " dir -- " ]
     [ compiled-offset        | " -- ptr " ]

library/platform/native/profiler.factor

@@ -36,8 +36,9 @@ USE: stack
 USE: words
 USE: vectors
 
-! The variable "profile-top-only" toggles between
+! The variable "only-top" toggles between
 ! culminative counts, and top of call stack counts.
+SYMBOL: only-top
 
 : reset-counts ( -- )
     [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
@@ -47,11 +48,7 @@ USE: vectors
 
 : call-count, ( word -- )
     #! Add to constructing list if call count is non-zero.
-    dup call-count dup 0 = [
+    dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-        2drop
-    ] [
-        cons ,
-    ] ifte ;
 
 : counts. ( alist -- )
     sort-counts [ . ] each ;
@@ -61,27 +58,21 @@ USE: vectors
     [, [ call-count, ] each-word ,] counts. ;
 
 : profile-depth ( -- n )
-    "profile-top-only" get [
+    only-top get [ -1 ] [ callstack vector-length ] ifte ;
-        -1
-    ] [
-        callstack vector-length
-    ] ifte ;
 
-: call-profile ( quot -- )
+: (call-profile) ( quot -- )
-    #! Execute a quotation with the CPU profiler enabled.
     reset-counts
     profile-depth call-profiling
     call
-    f call-profiling
+    f call-profiling ;
-    call-counts. ;
+
+: call-profile ( quot -- )
+    #! Execute a quotation with the CPU profiler enabled.
+    (call-profile) call-counts. ;
 
 : allot-count, ( word -- )
     #! Add to constructing list if allot count is non-zero.
-    dup allot-count dup 0 = [
+    dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-        2drop
-    ] [
-        cons ,
-    ] ifte ;
 
 : allot-counts. ( -- alist )
     #! Print word/allot count pairs.

library/test/math/irrational.factor

@@ -2,24 +2,29 @@ IN: scratchpad
 USE: kernel
 USE: math
 USE: test
+USE: real-math
 
-[ 4.0 ] [ 16 ] [ sqrt ] test-word
+! Lets get the argument order correct, eh?
-[ #{ 0 4.0 } ] [ -16 ] [ sqrt ] test-word
+[ 0.0 ] [ 0 1 fatan2 ] unit-test
+[ 0.25 ] [ 2 -2 fpow ] unit-test
 
-[ 4.0 ] [ 2 2 ] [ ^ ] test-word
+[ 4.0 ] [ 16 sqrt ] unit-test
-[ 0.25 ] [ 2 -2 ] [ ^ ] test-word
+[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test
-[ t ] [ 2 0.5 ^ 2 ^ ] [ 2 2.00001 between? ] test-word
-[ t ] [ e pi i * ^ real ] [ -1.0 = ] test-word
-[ t ] [ e pi i * ^ imaginary ] [ -0.00001 0.00001 between? ] test-word
 
-[ 1.0 ] [ 0 ] [ cosh ] test-word
+[ 4.0 ] [ 2 2 ^ ] unit-test
-[ 0.0 ] [ 1 ] [ acosh ] test-word
+[ 0.25 ] [ 2 -2 ^ ] unit-test
+[ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
+[ t ] [ e pi i * ^ real -1.0 = ] unit-test
+[ t ] [ e pi i * ^ imaginary -0.00001 0.00001 between? ] unit-test
 
-[ 1.0 ] [ 0 ] [ cos ] test-word
+[ 1.0 ] [ 0 cosh ] unit-test
-[ 0.0 ] [ 1 ] [ acos ] test-word
+[ 0.0 ] [ 1 acosh ] unit-test
             
-[ 0.0 ] [ 0 ] [ sinh ] test-word
+[ 1.0 ] [ 0 cos ] unit-test
-[ 0.0 ] [ 0 ] [ asinh ] test-word
+[ 0.0 ] [ 1 acos ] unit-test
             
-[ 0.0 ] [ 0 ] [ sin ] test-word
+[ 0.0 ] [ 0 sinh ] unit-test
-[ 0.0 ] [ 0 ] [ asin ] test-word
+[ 0.0 ] [ 0 asinh ] unit-test
+            
+[ 0.0 ] [ 0 sin ] unit-test
+[ 0.0 ] [ 0 asin ] unit-test

native/bignum.c

@@ -55,6 +55,7 @@ ARRAY* to_bignum(CELL tagged)
 
 void primitive_to_bignum(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(to_bignum(dpeek())));
 }
 
@@ -65,38 +66,39 @@ void primitive_bignum_eq(void)
 	dpush(tag_boolean(s48_bignum_equal_p(x,y)));
 }
 
+#define GC_AND_POP_BIGNUMS(x,y) \
+	ARRAY *x, *y; \
+	maybe_garbage_collection(); \
+	y = to_bignum(dpop()); \
+	x = to_bignum(dpop());
+
 void primitive_bignum_add(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_add(x,y)));
 }
 
 void primitive_bignum_subtract(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_subtract(x,y)));
 }
 
 void primitive_bignum_multiply(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_multiply(x,y)));
 }
 
 void primitive_bignum_divint(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_quotient(x,y)));
 }
 
 void primitive_bignum_divfloat(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(make_float(
 		s48_bignum_to_double(x) /
 		s48_bignum_to_double(y))));
@@ -104,9 +106,8 @@ void primitive_bignum_divfloat(void)
 
 void primitive_bignum_divmod(void)
 {
-	ARRAY* y = to_bignum(dpop());
-	ARRAY* x = to_bignum(dpop());
 	ARRAY *q, *r;
+	GC_AND_POP_BIGNUMS(x,y);
 	s48_bignum_divide(x,y,&q,&r);
 	dpush(tag_object(q));
 	dpush(tag_object(r));
@@ -114,36 +115,35 @@ void primitive_bignum_divmod(void)
 
 void primitive_bignum_mod(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_remainder(x,y)));
 }
 
 void primitive_bignum_and(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_bitwise_and(x,y)));
 }
 
 void primitive_bignum_or(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_bitwise_ior(x,y)));
 }
 
 void primitive_bignum_xor(void)
 {
-	ARRAY* y = to_bignum(dpop());
+	GC_AND_POP_BIGNUMS(x,y);
-	ARRAY* x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_bitwise_xor(x,y)));
 }
 
 void primitive_bignum_shift(void)
 {
-	FIXNUM y = to_fixnum(dpop());
+	FIXNUM y;
-	ARRAY* x = to_bignum(dpop());
+        ARRAY* x;
+	maybe_garbage_collection();
+	y = to_fixnum(dpop());
+	x = to_bignum(dpop());
 	dpush(tag_object(s48_bignum_arithmetic_shift(x,y)));
 }
 
@@ -207,6 +207,7 @@ void primitive_bignum_greatereq(void)
 
 void primitive_bignum_not(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(s48_bignum_bitwise_not(
 		untag_bignum(dpeek()))));
 }

native/complex.c

@@ -62,8 +62,12 @@ void primitive_to_rect(void)
 
 void primitive_from_rect(void)
 {
-	CELL imaginary = dpop();
+	CELL imaginary, real;
-	CELL real = dpop();
+
+	maybe_garbage_collection();
+
+	imaginary = dpop();
+	real = dpop();
 
 	if(!realp(imaginary))
 		type_error(REAL_TYPE,imaginary);

native/cons.c

@@ -10,8 +10,10 @@ CELL cons(CELL car, CELL cdr)
 
 void primitive_cons(void)
 {
-	CELL cdr = dpop();
+	CELL car, cdr;
-	CELL car = dpop();
+	maybe_garbage_collection();
+	cdr = dpop();
+	car = dpop();
 	dpush(cons(car,cdr));
 }
 

native/error.c

@@ -69,8 +69,8 @@ void type_error(CELL type, CELL tagged)
 	general_error(ERROR_TYPE,c);
 }
 
-void range_error(CELL tagged, CELL index, CELL max)
+void range_error(CELL tagged, FIXNUM index, CELL max)
 {
-	CELL c = cons(tagged,cons(tag_fixnum(index),cons(tag_fixnum(max),F)));
+	CELL c = cons(tagged,cons(tag_integer(index),cons(tag_cell(max),F)));
 	general_error(ERROR_RANGE,c);
 }

native/error.h

@@ -21,4 +21,4 @@ void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);
 void primitive_throw(void);
-void range_error(CELL tagged, CELL index, CELL max);
+void range_error(CELL tagged, FIXNUM index, CELL max);

native/factor.h

@@ -33,6 +33,11 @@
 typedef unsigned long int CELL;
 #define CELLS ((signed)sizeof(CELL))
 
+#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
+#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
+
+#define FIXNUM long int /* unboxed */
+
 #define WORD_SIZE (CELLS*8)
 #define HALF_WORD_SIZE (CELLS*4)
 #define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
@@ -46,7 +51,7 @@ typedef unsigned char BYTE;
 
 /* Memory heap size */
 #define DEFAULT_ARENA (64 * 1024 * 1024)
-#define COMPILE_ZONE_SIZE (5 * 1024 * 1024)
+#define COMPILE_ZONE_SIZE (4 * 1024 * 1024)
 
 #define STACK_SIZE 16384
 

native/ffi.c

@@ -12,10 +12,15 @@ DLL* untag_dll(CELL tagged)
 void primitive_dlopen(void)
 {
 #ifdef FFI
-	char* path = unbox_c_string();
+	char* path;
-	void* dllptr = dlopen(path,RTLD_LAZY);
+	void* dllptr;
 	DLL* dll;
 	
+	maybe_garbage_collection();
+	
+	path = unbox_c_string();
+	dllptr = dlopen(path,RTLD_LAZY);
+
 	if(dllptr == NULL)
 	{
 		general_error(ERROR_FFI,tag_object(
@@ -81,7 +86,9 @@ void primitive_alien(void)
 #ifdef FFI
 	CELL length = unbox_integer();
 	CELL ptr = unbox_integer();
-	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	ALIEN* alien;
+	maybe_garbage_collection();
+	alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
 	alien->ptr = ptr;
 	alien->length = length;
 	alien->local = false;
@@ -95,8 +102,11 @@ void primitive_local_alien(void)
 {
 #ifdef FFI
 	CELL length = unbox_integer();
-	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	ALIEN* alien;
-	STRING* local = string(length / CHARS,'\0');
+	STRING* local;
+	maybe_garbage_collection();
+	alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	local = string(length / CHARS,'\0');
 	alien->ptr = (CELL)local + sizeof(STRING);
 	alien->length = length;
 	alien->local = true;

native/file.c

@@ -4,9 +4,13 @@ void primitive_open_file(void)
 {
 	bool write = untag_boolean(dpop());
 	bool read = untag_boolean(dpop());
-	char* path = unbox_c_string();
+
-	int mode;
+	char* path;
-	int fd;
+	int mode, fd;
+
+	maybe_garbage_collection();
+
+	path = unbox_c_string();
 
 	if(read && write)
 		mode = O_RDWR | O_CREAT;
@@ -28,7 +32,11 @@ void primitive_open_file(void)
 void primitive_stat(void)
 {
 	struct stat sb;
-	STRING* path = untag_string(dpop());
+	STRING* path;
+
+	maybe_garbage_collection();
+
+	path = untag_string(dpop());
 	if(stat(to_c_string(path),&sb) < 0)
 		dpush(F);
 	else
@@ -50,14 +58,19 @@ void primitive_stat(void)
 
 void primitive_read_dir(void)
 {
-	STRING* path = untag_string(dpop());
+	STRING* path;
-	DIR* dir = opendir(to_c_string(path));
+	DIR* dir;
 	CELL result = F;
+
+	maybe_garbage_collection();
+
+	path = untag_string(dpop());
+	dir = opendir(to_c_string(path));
 	if(dir != NULL)
 	{
 		struct dirent* file;
 
-		while(file = readdir(dir))
+		while((file = readdir(dir)) != NULL)
 		{
 			CELL name = tag_object(from_c_string(
 				file->d_name));
@@ -73,6 +86,7 @@ void primitive_read_dir(void)
 void primitive_cwd(void)
 {
 	char wd[MAXPATHLEN];
+	maybe_garbage_collection();
 	if(getcwd(wd,MAXPATHLEN) < 0)
 		io_error(__FUNCTION__);
 	box_c_string(wd);
@@ -80,5 +94,6 @@ void primitive_cwd(void)
 
 void primitive_cd(void)
 {
+	maybe_garbage_collection();
 	chdir(unbox_c_string());
 }

native/fixnum.h

@@ -1,8 +1,3 @@
-#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
-#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
-
-#define FIXNUM long int /* unboxed */
-
 INLINE FIXNUM untag_fixnum_fast(CELL tagged)
 {
 	return ((FIXNUM)tagged) >> TAG_BITS;

native/float.c

@@ -27,15 +27,22 @@ double to_float(CELL tagged)
 
 void primitive_to_float(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(to_float(dpeek()))));
 }
 
 void primitive_str_to_float(void)
 {
-	STRING* str = untag_string(dpeek());
+	STRING* str;
-	char* c_str = to_c_string(str);
+	char *c_str, *end;
-	char* end = c_str;
+	double f;
-	double f = strtod(c_str,&end);
+
+	maybe_garbage_collection();
+
+	str = untag_string(dpeek());
+	c_str = to_c_string(str);
+	end = c_str;
+	f = strtod(c_str,&end);
 	if(end != c_str + str->capacity)
 		general_error(ERROR_FLOAT_FORMAT,tag_object(str));
 	drepl(tag_object(make_float(f)));
@@ -44,6 +51,9 @@ void primitive_str_to_float(void)
 void primitive_float_to_str(void)
 {
 	char tmp[33];
+
+	maybe_garbage_collection();
+
 	snprintf(tmp,32,"%.16g",to_float(dpop()));
 	tmp[32] = '\0';
 	box_c_string(tmp);
@@ -51,43 +61,49 @@ void primitive_float_to_str(void)
 
 void primitive_float_to_bits(void)
 {
-	double f = untag_float(dpeek());
+	double f;
-	long long f_raw = *(long long*)&f;
+	long long f_raw;
+
+	maybe_garbage_collection();
+
+	f = untag_float(dpeek());
+	f_raw = *(long long*)&f;
 	drepl(tag_object(s48_long_long_to_bignum(f_raw)));
 }
 
+#define GC_AND_POP_FLOATS(x,y) \
+	double x, y; \
+	maybe_garbage_collection(); \
+	y = to_float(dpop()); \
+	x = to_float(dpop());
+
 void primitive_float_eq(void)
 {
-	double y = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double x = to_float(dpop());
 	dpush(tag_boolean(x == y));
 }
 
 void primitive_float_add(void)
 {
-	double y = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double x = to_float(dpop());
 	dpush(tag_object(make_float(x + y)));
 }
 
 void primitive_float_subtract(void)
 {
-	double y = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double x = to_float(dpop());
 	dpush(tag_object(make_float(x - y)));
 }
 
 void primitive_float_multiply(void)
 {
-	double y = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double x = to_float(dpop());
 	dpush(tag_object(make_float(x * y)));
 }
 
 void primitive_float_divfloat(void)
 {
-	double y = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double x = to_float(dpop());
 	dpush(tag_object(make_float(x / y)));
 }
 
@@ -121,64 +137,72 @@ void primitive_float_greatereq(void)
 
 void primitive_facos(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(acos(to_float(dpeek())))));
 }
 
 void primitive_fasin(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(asin(to_float(dpeek())))));
 }
 
 void primitive_fatan(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(atan(to_float(dpeek())))));
 }
 
 void primitive_fatan2(void)
 {
-	double x = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double y = to_float(dpop());
+	dpush(tag_object(make_float(atan2(x,y))));
-	dpush(tag_object(make_float(atan2(y,x))));
 }
 
 void primitive_fcos(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(cos(to_float(dpeek())))));
 }
 
 void primitive_fexp(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(exp(to_float(dpeek())))));
 }
 
 void primitive_fcosh(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(cosh(to_float(dpeek())))));
 }
 
 void primitive_flog(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(log(to_float(dpeek())))));
 }
 
 void primitive_fpow(void)
 {
-	double x = to_float(dpop());
+	GC_AND_POP_FLOATS(x,y);
-	double y = to_float(dpop());
+	dpush(tag_object(make_float(pow(x,y))));
-	dpush(tag_object(make_float(pow(y,x))));
 }
 
 void primitive_fsin(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(sin(to_float(dpeek())))));
 }
 
 void primitive_fsinh(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(sinh(to_float(dpeek())))));
 }
 
 void primitive_fsqrt(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(make_float(sqrt(to_float(dpeek())))));
 }

native/gc.c

@@ -132,6 +132,7 @@ void collect_roots(void)
 
 void primitive_gc(void)
 {
+	fprintf(stderr,"GC!\n");
 	gc_in_progress = true;
 
 	flip_zones();
@@ -149,3 +150,23 @@ void primitive_gc(void)
 
 	gc_in_progress = false;
 }
+
+/* WARNING: only call this from a context where all local variables
+are also reachable via the GC roots. */
+void maybe_garbage_collection(void)
+{
+	if(active.here > active.alarm)
+	{
+		if(active.here > active.limit)
+		{
+			fprintf(stderr,"Out of memory\n");
+			fprintf(stderr,"active.base  = %ld\n",active.base);
+			fprintf(stderr,"active.here  = %ld\n",active.here);
+			fprintf(stderr,"active.limit = %ld\n",active.limit);
+			fflush(stderr);
+			exit(1);
+		}
+		else
+			primitive_gc();
+	}
+}

native/gc.h

@@ -7,3 +7,4 @@ void collect_object(void);
 void collect_next(void);
 void collect_roots(void);
 void primitive_gc(void);
+void maybe_garbage_collection(void);

native/memory.c

@@ -36,7 +36,6 @@ void init_arena(CELL size)
 	init_zone(&prior,size);
 	allot_profiling = false;
 	gc_in_progress = false;
-	gc_protect = false;
 }
 
 void allot_profile_step(CELL a)
@@ -58,25 +57,6 @@ void allot_profile_step(CELL a)
 	executing->allot_count += a;
 }
 
-void garbage_collection_later(void)
-{
-	if(gc_protect)
-		return;
-
-	if(active.here > active.limit)
-	{
-		fprintf(stderr,"Out of memory\n");
-		fprintf(stderr,"active.base  = %ld\n",active.base);
-		fprintf(stderr,"active.here  = %ld\n",active.here);
-		fprintf(stderr,"active.limit = %ld\n",active.limit);
-		fflush(stderr);
-		exit(1);
-	}
-
-	/* Execute the 'garbage-collection' word */
-	call(userenv[GC_ENV]);
-}
-
 void flip_zones()
 {
 	ZONE z = active;

native/memory.h

@@ -10,15 +10,11 @@ ZONE prior;
 
 bool allot_profiling;
 
-/* we can temporarily disable GC */
-bool gc_protect;
-
 void* alloc_guarded(CELL size);
 void init_zone(ZONE* zone, CELL size);
 void init_arena(CELL size);
 void flip_zones();
 
-void garbage_collection_later(void);
 void allot_profile_step(CELL a);
 
 INLINE CELL align8(CELL a)
@@ -32,8 +28,6 @@ INLINE void* allot(CELL a)
 	active.here += align8(a);
 	if(allot_profiling)
 		allot_profile_step(align8(a));
-	if(active.here > active.alarm)
-		garbage_collection_later();
 	return (void*)h;
 }
 

native/misc.c

@@ -7,8 +7,12 @@ void primitive_exit(void)
 
 void primitive_os_env(void)
 {
-	char* name = unbox_c_string();
+	char *name, *value;
-	char* value = getenv(name);
+
+	maybe_garbage_collection();
+
+	name = unbox_c_string();
+	value = getenv(name);
 	if(value == NULL)
 		dpush(F);
 	else
@@ -24,6 +28,7 @@ void primitive_millis(void)
 {
 	struct timeval t;
 	gettimeofday(&t,NULL);
+	maybe_garbage_collection();
 	dpush(tag_object(s48_long_long_to_bignum(
 		(long long)t.tv_sec * 1000 + t.tv_usec/1000)));
 }
@@ -41,15 +46,6 @@ void primitive_init_random(void)
 
 void primitive_random_int(void)
 {
+	maybe_garbage_collection();
 	dpush(tag_object(s48_long_to_bignum(random())));
 }
-
-void primitive_dump(void)
-{
-	/* Take an object, and print its memory. Later, return a vector */
-	CELL obj = dpop();
-	CELL size = object_size(obj);
-	int i;
-	for(i = 0; i < size; i += CELLS)
-		fprintf(stderr,"%lx\n",get(UNTAG(obj) + i));
-}

native/misc.h

@@ -4,4 +4,3 @@ void primitive_eq(void);
 void primitive_millis(void);
 void primitive_init_random(void);
 void primitive_random_int(void);
-void primitive_dump(void);

native/primitives.c

@@ -169,7 +169,6 @@ XT primitives[] = {
 	primitive_random_int,
 	primitive_type,
 	primitive_size,
-	primitive_dump,
 	primitive_cwd,
 	primitive_cd,
 	primitive_compiled_offset,

native/ratio.c

@@ -4,8 +4,12 @@
 library implementation, to avoid breaking invariants. */
 void primitive_from_fraction(void)
 {
-	CELL denominator = dpop();
+	CELL numerator, denominator;
-	CELL numerator = dpop();
+
+	maybe_garbage_collection();
+
+	denominator = dpop();
+	numerator = dpop();
 	if(zerop(denominator))
 		raise(SIGFPE);
 	if(onep(denominator))

native/read.c

@@ -107,8 +107,12 @@ void primitive_can_read_line(void)
 
 void primitive_add_read_line_io_task(void)
 {
-	CELL callback = dpop();
+	CELL callback, port;
-	CELL port = dpop();
+
+	maybe_garbage_collection();
+
+	callback = dpop();
+	port = dpop();
 	add_io_task(IO_TASK_READ_LINE,port,F,callback,
 		read_io_tasks,&read_fd_count);
 
@@ -140,7 +144,11 @@ bool perform_read_line_io_task(PORT* port)
 
 void primitive_read_line_8(void)
 {
-	PORT* port = untag_port(dpeek());
+	PORT* port;
+
+	maybe_garbage_collection();
+
+	port = untag_port(dpeek());
 
 	pending_io_error(port);
 
@@ -199,16 +207,27 @@ bool can_read_count(PORT* port, FIXNUM count)
 
 void primitive_can_read_count(void)
 {
-	PORT* port = untag_port(dpop());
+	PORT* port;
-	FIXNUM len = to_fixnum(dpop());
+	FIXNUM len;
+
+	maybe_garbage_collection();
+
+	port = untag_port(dpop());
+	len = to_fixnum(dpop());
 	dpush(tag_boolean(can_read_count(port,len)));
 }
 
 void primitive_add_read_count_io_task(void)
 {
-	CELL callback = dpop();
+	CELL callback;
-	PORT* port = untag_port(dpop());
+	PORT* port;
-	FIXNUM count = to_fixnum(dpop());
+	FIXNUM count;
+
+	maybe_garbage_collection();
+
+	callback = dpop();
+	port = untag_port(dpop());
+	count = to_fixnum(dpop());
 	add_io_task(IO_TASK_READ_COUNT,
 		tag_object(port),F,callback,
 		read_io_tasks,&read_fd_count);
@@ -233,8 +252,13 @@ bool perform_read_count_io_task(PORT* port)
 
 void primitive_read_count_8(void)
 {
-	PORT* port = untag_port(dpop());
+	PORT* port;
-	FIXNUM len = to_fixnum(dpop());
+	FIXNUM len;
+
+	maybe_garbage_collection();
+
+	port = untag_port(dpop());
+	len = to_fixnum(dpop());
 	if(port->count != len)
 		critical_error("read# counts don't match",tag_object(port));
 

native/sbuf.c

@@ -10,6 +10,7 @@ SBUF* sbuf(FIXNUM capacity)
 
 void primitive_sbuf(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(sbuf(to_fixnum(dpeek()))));
 }
 
@@ -20,8 +21,13 @@ void primitive_sbuf_length(void)
 
 void primitive_set_sbuf_length(void)
 {
-	SBUF* sbuf = untag_sbuf(dpop());
+	SBUF* sbuf;
-	FIXNUM length = to_fixnum(dpop());
+	FIXNUM length;
+
+	maybe_garbage_collection();
+
+	sbuf = untag_sbuf(dpop());
+	length = to_fixnum(dpop());
 	if(length < 0)
 		range_error(tag_object(sbuf),length,sbuf->top);
 	sbuf->top = length;
@@ -61,9 +67,15 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value)
 
 void primitive_set_sbuf_nth(void)
 {
-	SBUF* sbuf = untag_sbuf(dpop());
+	SBUF* sbuf;
-	FIXNUM index = to_fixnum(dpop());
+	FIXNUM index;
-	CELL value = dpop();
+	CELL value;
+
+	maybe_garbage_collection();
+
+	sbuf = untag_sbuf(dpop());
+	index = to_fixnum(dpop());
+	value = dpop();
 
 	set_sbuf_nth(sbuf,index,value);
 }
@@ -79,8 +91,14 @@ void sbuf_append_string(SBUF* sbuf, STRING* string)
 
 void primitive_sbuf_append(void)
 {
-	SBUF* sbuf = untag_sbuf(dpop());
+	SBUF* sbuf;
-	CELL object = dpop();
+	CELL object;
+
+	maybe_garbage_collection();
+
+	sbuf = untag_sbuf(dpop());
+	object = dpop();
+
 	switch(type_of(object))
 	{
 	case FIXNUM_TYPE:
@@ -98,8 +116,13 @@ void primitive_sbuf_append(void)
 
 void primitive_sbuf_to_string(void)
 {
-	SBUF* sbuf = untag_sbuf(dpeek());
+	SBUF* sbuf;
-	STRING* s = string_clone(sbuf->string,sbuf->top);
+	STRING* s;
+
+	maybe_garbage_collection();
+
+	sbuf = untag_sbuf(dpeek());
+	s = string_clone(sbuf->string,sbuf->top);
 	rehash_string(s);
 	drepl(tag_object(s));
 }
@@ -112,8 +135,14 @@ void primitive_sbuf_reverse(void)
 
 void primitive_sbuf_clone(void)
 {
-	SBUF* s = untag_sbuf(dpeek());
+	SBUF* s;
-	SBUF* new_s = sbuf(s->top);
+	SBUF* new_s;
+
+	maybe_garbage_collection();
+
+	s = untag_sbuf(dpeek());
+	new_s = sbuf(s->top);
+
 	sbuf_append_string(new_s,s->string);
 	drepl(tag_object(new_s));
 }

native/socket.c

@@ -45,8 +45,14 @@ int make_client_socket(const char* hostname, uint16_t port)
 void primitive_client_socket(void)
 {
 	uint16_t p = (uint16_t)to_fixnum(dpop());
-	char* host = unbox_c_string();
+	char* host;
-	int sock = make_client_socket(host,p);
+	int sock;
+
+	maybe_garbage_collection();
+
+	host = unbox_c_string();
+	sock = make_client_socket(host,p);
+
 	dpush(tag_object(port(PORT_RECV,sock)));
 	dpush(tag_object(port(PORT_WRITE,sock)));
 }
@@ -91,13 +97,16 @@ int make_server_socket(uint16_t port)
 void primitive_server_socket(void)
 {
 	uint16_t p = (uint16_t)to_fixnum(dpop());
+	maybe_garbage_collection();
 	dpush(tag_object(port(PORT_SPECIAL,make_server_socket(p))));
 }
 
 void primitive_add_accept_io_task(void)
 {
-	CELL callback = dpop();
+	CELL callback, port;
-	CELL port = dpop();
+	maybe_garbage_collection();
+	callback = dpop();
+	port = dpop();
 	add_io_task(IO_TASK_ACCEPT,port,F,callback,
 		read_io_tasks,&read_fd_count);
 }
@@ -131,7 +140,9 @@ CELL accept_connection(PORT* p)
 
 void primitive_accept_fd(void)
 {
-	PORT* p = untag_port(dpop());
+	PORT* p;
+	maybe_garbage_collection();
+	p = untag_port(dpop());
 	dpush(p->client_host);
 	dpush(p->client_port);
 	dpush(tag_object(port(PORT_RECV,p->client_socket)));

native/stack.c

@@ -94,15 +94,14 @@ VECTOR* stack_to_vector(CELL bottom, CELL top)
 
 void primitive_datastack(void)
 {
+	maybe_garbage_collection();
 	dpush(tag_object(stack_to_vector(ds_bot,ds)));
 }
 
 void primitive_callstack(void)
 {
-	/* we don't want gc word to end up on callstack. */
+	maybe_garbage_collection();
-	gc_protect = true;
 	dpush(tag_object(stack_to_vector(cs_bot,cs)));
-	gc_protect = false;
 }
 
 /* Returns top of stack */

native/string.c

@@ -274,9 +274,14 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
 /* start end string -- string */
 void primitive_substring(void)
 {
-	STRING* string = untag_string(dpop());
+	STRING* string;
-	CELL end = to_fixnum(dpop());
+	CELL end, start;
-	CELL start = to_fixnum(dpop());
+
+	maybe_garbage_collection();
+
+	string = untag_string(dpop());
+	end = to_fixnum(dpop());
+	start = to_fixnum(dpop());
 	dpush(tag_object(substring(start,end,string)));
 }
 
@@ -305,7 +310,11 @@ STRING* string_clone(STRING* s, int len)
 
 void primitive_string_reverse(void)
 {
-	STRING* s = untag_string(dpeek());
+	STRING* s;
+
+	maybe_garbage_collection();
+
+	s = untag_string(dpeek());
 	s = string_clone(s,s->capacity);
 	string_reverse(s,s->capacity);
 	rehash_string(s);

native/vector.c

@@ -10,6 +10,7 @@ VECTOR* vector(FIXNUM capacity)
 
 void primitive_vector(void)
 {
+	maybe_garbage_collection();
 	drepl(tag_object(vector(to_fixnum(dpeek()))));
 }
 
@@ -20,8 +21,13 @@ void primitive_vector_length(void)
 
 void primitive_set_vector_length(void)
 {
-	VECTOR* vector = untag_vector(dpop());
+	VECTOR* vector;
-	FIXNUM length = to_fixnum(dpop());
+	FIXNUM length;
+
+	maybe_garbage_collection();
+
+	vector = untag_vector(dpop());
+	length = to_fixnum(dpop());
 	if(length < 0)
 		range_error(tag_object(vector),length,vector->top);
 	vector->top = length;
@@ -51,9 +57,15 @@ void vector_ensure_capacity(VECTOR* vector, CELL index)
 
 void primitive_set_vector_nth(void)
 {
-	VECTOR* vector = untag_vector(dpop());
+	VECTOR* vector;
-	FIXNUM index = to_fixnum(dpop());
+	FIXNUM index;
-	CELL value = dpop();
+	CELL value;
+
+	maybe_garbage_collection();
+
+	vector = untag_vector(dpop());
+	index = to_fixnum(dpop());
+	value = dpop();
 
 	if(index < 0)
 		range_error(tag_object(vector),index,vector->top);

native/word.c

@@ -25,9 +25,13 @@ void update_xt(WORD* word)
 /* <word> ( primitive parameter plist -- word ) */
 void primitive_word(void)
 {
-	CELL plist = dpop();
+	CELL plist, parameter;
 	FIXNUM primitive;
-	CELL parameter = dpop();
+
+	maybe_garbage_collection();
+
+	plist = dpop();
+	parameter = dpop();
 	primitive = to_fixnum(dpop());
 	dpush(tag_word(word(primitive,parameter,plist)));
 }

native/write.c

@@ -38,16 +38,25 @@ bool can_write(PORT* port, FIXNUM len)
 
 void primitive_can_write(void)
 {
-	PORT* port = untag_port(dpop());
+	PORT* port;
-	FIXNUM len = to_fixnum(dpop());
+	FIXNUM len;
+
+	maybe_garbage_collection();
+	
+	port = untag_port(dpop());
+	len = to_fixnum(dpop());
 	pending_io_error(port);
 	dpush(tag_boolean(can_write(port,len)));
 }
 
 void primitive_add_write_io_task(void)
 {
-	CELL callback = dpop();
+	CELL callback, port;
-	CELL port = dpop();
+
+	maybe_garbage_collection();
+
+	callback = dpop();
+	port = dpop();
 	add_io_task(IO_TASK_WRITE,port,F,callback,
 		write_io_tasks,&write_fd_count);
 }
@@ -107,12 +116,17 @@ void write_string_8(PORT* port, STRING* str)
 
 void primitive_write_8(void)
 {
-	PORT* port = untag_port(dpop());
+	PORT* port;
-
+	CELL text, type;
-	CELL text = dpop();
-	CELL type = type_of(text);
 	STRING* str;
 
+	maybe_garbage_collection();
+
+	port = untag_port(dpop());
+
+	text = dpop();
+	type = type_of(text);
+
 	pending_io_error(port);
 
 	switch(type)