Sprinkle VM source with assertions, add a missing local root to quotations.c, fix GROWABLE_ARRAY macros for GC safety

Makefile

@@ -13,7 +13,7 @@ CFLAGS = -Wall
 FFI_TEST_CFLAGS = -fPIC
 
 ifdef DEBUG
-	CFLAGS += -g
+	CFLAGS += -g -DFACTOR_DEBUG
 else
 	CFLAGS += -O3
 endif

vm/bignumint.h

@@ -64,7 +64,7 @@ typedef F_FIXNUM bignum_length_type;
 
 #define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
 
-#define BIGNUM_NEGATIVE_P(bignum) (array_nth(bignum,0) != 0)
+#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
 #define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
 
 #define BIGNUM_ZERO_P(bignum)						\

vm/code_block.c

@@ -184,6 +184,13 @@ void update_word_references(F_CODE_BLOCK *compiled)
 	}
 }
 
+INLINE void check_code_address(CELL address)
+{
+#ifdef FACTOR_DEBUG
+	assert(address >= code_heap.segment->start && address < code_heap.segment->end);
+#endif
+}
+
 /* Update references to words. This is done after a new code block
 is added to the heap. */
 
@@ -191,6 +198,8 @@ is added to the heap. */
 collections */
 void mark_code_block(F_CODE_BLOCK *compiled)
 {
+	check_code_address((CELL)compiled);
+
 	mark_block(&compiled->block);
 
 	copy_handle(&compiled->literals);
@@ -287,6 +296,11 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index)
 /* Compute an address to store at a relocation */
 void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
 {
+#ifdef FACTOR_DEBUG
+	type_check(ARRAY_TYPE,compiled->literals);
+	type_check(BYTE_ARRAY_TYPE,compiled->relocation);
+#endif
+
 	CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
 	F_ARRAY *literals = untag_object(compiled->literals);
 	F_FIXNUM absolute_value;
@@ -410,6 +424,12 @@ F_CODE_BLOCK *add_code_block(
 	CELL relocation,
 	CELL literals)
 {
+#ifdef FACTOR_DEBUG
+	type_check(ARRAY_TYPE,literals);
+	type_check(BYTE_ARRAY_TYPE,relocation);
+	assert(hi_tag(code) == ARRAY_TYPE);
+#endif
+
 	CELL code_format = compiled_code_format();
 	CELL code_length = align8(array_capacity(code) * code_format);
 
@@ -436,6 +456,11 @@ F_CODE_BLOCK *add_code_block(
 	compiled->literals = literals;
 	compiled->relocation = relocation;
 
+#ifdef FACTOR_DEBUG
+	type_check(ARRAY_TYPE,compiled->literals);
+	type_check(BYTE_ARRAY_TYPE,compiled->relocation);
+#endif
+
 	/* code */
 	deposit_integers((CELL)(compiled + 1),code,code_format);
 

vm/code_heap.c

@@ -97,7 +97,7 @@ void primitive_modify_code_heap(void)
 		{
 			F_ARRAY *compiled_code = untag_array(data);
 
-			F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
+			CELL literals = array_nth(compiled_code,0);
 			CELL relocation = array_nth(compiled_code,1);
 			F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
 			F_ARRAY *code = untag_array(array_nth(compiled_code,3));
@@ -110,7 +110,7 @@ void primitive_modify_code_heap(void)
 				code,
 				labels,
 				relocation,
-				tag_object(literals));
+				literals);
 
 			UNREGISTER_UNTAGGED(word);
 			UNREGISTER_UNTAGGED(alist);

vm/data_gc.c

@@ -1,5 +1,16 @@
 #include "master.h"
 
+INLINE void check_data_pointer(CELL pointer)
+{
+#ifdef FACTOR_DEBUG
+	if(!growing_data_heap)
+	{
+		assert(pointer >= data_heap->segment->start
+		       && pointer < data_heap->segment->end);
+	}
+#endif
+}
+
 /* Scan all the objects in the card */
 void copy_card(F_CARD *ptr, CELL gen, CELL here)
 {
@@ -211,6 +222,8 @@ INLINE CELL copy_object_impl(CELL pointer)
 /* Follow a chain of forwarding pointers */
 CELL resolve_forwarding(CELL untagged, CELL tag)
 {
+	check_data_pointer(untagged);
+
 	CELL header = get(untagged);
 	/* another forwarding pointer */
 	if(TAG(header) == GC_COLLECTED)
@@ -218,6 +231,7 @@ CELL resolve_forwarding(CELL untagged, CELL tag)
 	/* we've found the destination */
 	else
 	{
+		check_header(header);
 		CELL pointer = RETAG(untagged,tag);
 		if(should_copy(untagged))
 			pointer = RETAG(copy_object_impl(pointer),tag);
@@ -231,21 +245,30 @@ pointer address without copying anything; otherwise, install
 a new forwarding pointer. */
 INLINE CELL copy_object(CELL pointer)
 {
+	check_data_pointer(pointer);
+
 	CELL tag = TAG(pointer);
 	CELL header = get(UNTAG(pointer));
 
 	if(TAG(header) == GC_COLLECTED)
 		return resolve_forwarding(UNTAG(header),tag);
 	else
+	{
+		check_header(header);
 		return RETAG(copy_object_impl(pointer),tag);
+	}
 }
 
 void copy_handle(CELL *handle)
 {
 	CELL pointer = *handle;
 
-	if(!immediate_p(pointer) && should_copy(pointer))
+	if(!immediate_p(pointer))
-		*handle = copy_object(pointer);
+	{
+		check_data_pointer(pointer);
+		if(should_copy(pointer))
+			*handle = copy_object(pointer);
+	}
 }
 
 CELL copy_next_from_nursery(CELL scan)
@@ -264,9 +287,12 @@ CELL copy_next_from_nursery(CELL scan)
 		{
 			CELL pointer = *obj;
 
-			if(!immediate_p(pointer)
+			if(!immediate_p(pointer))
-				&& (pointer >= nursery_start && pointer < nursery_end))
+			{
-				*obj = copy_object(pointer);
+				check_data_pointer(pointer);
+				if(pointer >= nursery_start && pointer < nursery_end)
+					*obj = copy_object(pointer);
+			}
 		}
 	}
 
@@ -292,10 +318,13 @@ CELL copy_next_from_aging(CELL scan)
 		{
 			CELL pointer = *obj;
 
-			if(!immediate_p(pointer)
+			if(!immediate_p(pointer))
-				&& !(pointer >= newspace_start && pointer < newspace_end)
+			{
-				&& !(pointer >= tenured_start && pointer < tenured_end))
+				check_data_pointer(pointer);
-				*obj = copy_object(pointer);
+				if(!(pointer >= newspace_start && pointer < newspace_end)
+				   && !(pointer >= tenured_start && pointer < tenured_end))
+					*obj = copy_object(pointer);
+			}
 		}
 	}
 
@@ -318,8 +347,12 @@ CELL copy_next_from_tenured(CELL scan)
 		{
 			CELL pointer = *obj;
 
-			if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
+			if(!immediate_p(pointer))
-				*obj = copy_object(pointer);
+			{
+				check_data_pointer(pointer);
+				if(!(pointer >= newspace_start && pointer < newspace_end))
+					*obj = copy_object(pointer);
+			}
 		}
 	}
 
@@ -474,6 +507,7 @@ void garbage_collection(CELL gen,
 	copy_roots();
 	/* collect objects referenced from older generations */
 	copy_cards();
+
 	/* do some tracing */
 	copy_reachable_objects(scan,&newspace->here);
 

vm/data_gc.h

@@ -93,7 +93,7 @@ INLINE void *allot_object(CELL type, CELL a)
 #ifdef GC_DEBUG
 	if(!gc_off)
 	{
-		if(gc_count++ % 1000 == 0)
+		if(gc_count++ % 100 == 0)
 			gc();
 
 	}

vm/factor.c

@@ -118,7 +118,10 @@ void init_factor(F_PARAMETERS *p)
 	init_stacks(p->ds_size,p->rs_size);
 	load_image(p);
 	init_c_io();
+
+#ifndef FACTOR_DEBUG
 	init_signals();
+#endif
 
 	if(p->console)
 		open_console();

vm/master.h

@@ -2,7 +2,11 @@
 #define __FACTOR_MASTER_H__
 
 #ifndef WINCE
-	#include <errno.h>
+#include <errno.h>
+#endif
+
+#ifdef FACTOR_DEBUG
+#include <assert.h>
 #endif
 
 #include <fcntl.h>

vm/profiler.c

@@ -48,7 +48,8 @@ void update_word_xt(F_WORD *word)
 		word->xt = (XT)(word->code + 1);
 }
 
-void set_profiling(bool profiling)
+/* Allocates memory */
+static void set_profiling(bool profiling)
 {
 	if(profiling == profiling_p)
 		return;

vm/quotations.c

@@ -204,6 +204,8 @@ void jit_compile(CELL quot, bool relocate)
 	for(i = 0; i < length; i++)
 	{
 		CELL obj = array_nth(untag_object(array),i);
+		REGISTER_ROOT(obj);
+
 		F_WORD *word;
 		F_WRAPPER *wrapper;
 
@@ -325,6 +327,8 @@ void jit_compile(CELL quot, bool relocate)
 			EMIT(userenv[JIT_PUSH_IMMEDIATE])
 			break;
 		}
+
+		UNREGISTER_ROOT(obj);
 	}
 
 	if(!tail_call)
@@ -339,6 +343,10 @@ void jit_compile(CELL quot, bool relocate)
 	GROWABLE_BYTE_ARRAY_TRIM(relocation);
 	GROWABLE_ARRAY_TRIM(code);
 
+	GROWABLE_ARRAY_DONE(literals);
+	GROWABLE_BYTE_ARRAY_DONE(relocation);
+	GROWABLE_ARRAY_DONE(code);
+
 	F_CODE_BLOCK *compiled = add_code_block(
 		QUOTATION_TYPE,
 		untag_object(code),
@@ -351,10 +359,6 @@ void jit_compile(CELL quot, bool relocate)
 	if(relocate)
 		relocate_code_block(compiled);
 
-	GROWABLE_ARRAY_DONE(literals);
-	GROWABLE_BYTE_ARRAY_DONE(relocation);
-	GROWABLE_ARRAY_DONE(code);
-
 	UNREGISTER_ROOT(array);
 	UNREGISTER_ROOT(quot);
 }
@@ -536,10 +540,13 @@ void compile_all_words(void)
 	{
 		F_WORD *word = untag_word(array_nth(untag_array(words),i));
 		REGISTER_UNTAGGED(word);
+
 		if(word->optimizedp == F)
 			jit_compile_word(word,word->def,false);
+
 		UNREGISTER_UNTAGGED(word);
 		update_word_xt(word);
+
 	}
 
 	UNREGISTER_ROOT(words);

vm/run.h

@@ -129,8 +129,16 @@ INLINE CELL tag_header(CELL cell)
 	return cell << TAG_BITS;
 }
 
+INLINE void check_header(CELL cell)
+{
+#ifdef FACTOR_DEBUG
+	assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT);
+#endif
+}
+
 INLINE CELL untag_header(CELL cell)
 {
+	check_header(cell);
 	return cell >> TAG_BITS;
 }
 

vm/types.c

@@ -224,7 +224,7 @@ void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
 
 	UNREGISTER_UNTAGGED(elts);
 
-	write_barrier((CELL)array->array);
+	write_barrier(array->array);
 
 	memcpy((void *)AREF(underlying,array->count),
 	       (void *)AREF(elts,0),

vm/types.h

@@ -40,25 +40,37 @@ INLINE CELL tag_boolean(CELL untagged)
 
 DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
 
+INLINE CELL array_capacity(F_ARRAY* array)
+{
+#ifdef FACTOR_DEBUG
+	CELL header = untag_header(array->header);
+	assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
+#endif
+	return array->capacity >> TAG_BITS;
+}
+
 #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
 #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
 
 INLINE CELL array_nth(F_ARRAY *array, CELL slot)
 {
+#ifdef FACTOR_DEBUG
+	assert(slot < array_capacity(array));
+	assert(untag_header(array->header) == ARRAY_TYPE);
+#endif
 	return get(AREF(array,slot));
 }
 
 INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
 {
+#ifdef FACTOR_DEBUG
+	assert(slot < array_capacity(array));
+	assert(untag_header(array->header) == ARRAY_TYPE);
+#endif
 	put(AREF(array,slot),value);
 	write_barrier((CELL)array);
 }
 
-INLINE CELL array_capacity(F_ARRAY* array)
-{
-	return array->capacity >> TAG_BITS;
-}
-
 #define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
 #define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
 
@@ -164,11 +176,12 @@ typedef struct {
 	CELL array;
 } F_GROWABLE_ARRAY;
 
+/* Allocates memory */
 INLINE F_GROWABLE_ARRAY make_growable_array(void)
 {
 	F_GROWABLE_ARRAY result;
 	result.count = 0;
-	result.array = tag_object(allot_array(ARRAY_TYPE,10000,F));
+	result.array = tag_object(allot_array(ARRAY_TYPE,100,F));
 	return result;
 }
 
@@ -185,14 +198,16 @@ void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
 #define GROWABLE_ARRAY_APPEND(result,elts) \
 	growable_array_append(&result##_g,elts)
 
-INLINE CELL growable_array_trim(F_GROWABLE_ARRAY *array)
+INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
 {
-	return tag_object(reallot_array(untag_object(array->array),array->count));
+	array->array = tag_object(reallot_array(untag_object(array->array),array->count));
 }
 
-#define GROWABLE_ARRAY_TRIM(result) CELL result = growable_array_trim(&result##_g)
+#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
 
-#define GROWABLE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array)
+#define GROWABLE_ARRAY_DONE(result) \
+	UNREGISTER_ROOT(result##_g.array); \
+	CELL result = result##_g.array;
 
 /* Macros to simulate a byte vector in C */
 typedef struct {
@@ -204,7 +219,7 @@ INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
 {
 	F_GROWABLE_BYTE_ARRAY result;
 	result.count = 0;
-	result.array = tag_object(allot_byte_array(10000));
+	result.array = tag_object(allot_byte_array(100));
 	return result;
 }
 
@@ -217,11 +232,13 @@ void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL
 #define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
 	growable_byte_array_append(&result##_g,elts,len)
 
-INLINE CELL growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
+INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
 {
-	return tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
+	byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
 }
 
-#define GROWABLE_BYTE_ARRAY_TRIM(result) CELL result = growable_byte_array_trim(&result##_g)
+#define GROWABLE_BYTE_ARRAY_TRIM(result) growable_byte_array_trim(&result##_g)
 
-#define GROWABLE_BYTE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array);
+#define GROWABLE_BYTE_ARRAY_DONE(result) \
+	UNREGISTER_ROOT(result##_g.array); \
+	CELL result = result##_g.array;