Fix code heap compaction and clean up VM a bit

vm/code_gc.c

@@ -415,7 +415,7 @@ void fixup_object_xts(void)
 			if(word->compiledp != F)
 				set_word_xt(word,word->code);
 			else
-				word->xt = word->code + sizeof(F_COMPILED);
+				word->xt = (void *)(word->code + 1);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{

vm/code_heap.c

@@ -138,22 +138,27 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue);
+	if(reloc_start != literals_start)
-
-	F_REL *rel = (F_REL *)reloc_start;
-	F_REL *rel_end = (F_REL *)literals_start;
-
-	while(rel < rel_end)
 	{
-		CELL offset = rel->offset + code_start;
+		xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue);
 
-		F_FIXNUM absolute_value = compute_code_rel(rel,
+		F_REL *rel = (F_REL *)reloc_start;
-			code_start,literals_start,words_start);
+		F_REL *rel_end = (F_REL *)literals_start;
 
-		apply_relocation(REL_CLASS(rel),offset,absolute_value);
+		while(rel < rel_end)
+		{
+			CELL offset = rel->offset + code_start;
 
-		rel++;
+			F_FIXNUM absolute_value = compute_code_rel(rel,
+				code_start,literals_start,words_start);
+
+			apply_relocation(REL_CLASS(rel),offset,absolute_value);
+
+			rel++;
+		}
 	}
+
+	flush_icache(code_start,reloc_start - code_start);
 }
 
 /* Fixup labels. This is done at compile time, not image load time */
@@ -384,5 +389,5 @@ DEFINE_PRIMITIVE(modify_code_heap)
 	}
 
 	if(count != 0)
-		iterate_code_heap(finalize_code_block);
+		iterate_code_heap(relocate_code_block);
 }

vm/code_heap.h

@@ -56,9 +56,6 @@ typedef struct {
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
-void finalize_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
-
 void set_word_xt(F_WORD *word, F_COMPILED *compiled);
 
 F_COMPILED *add_compiled_block(

vm/cpu-arm.h

@@ -8,8 +8,6 @@ register CELL rs asm("r6");
 #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
 
 void c_to_factor(CELL quot);
-void docol_profiling(CELL word);
-void docol(CELL word);
 void undefined(CELL word);
 void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
 void throw_impl(CELL quot, F_STACK_FRAME *rewind);

vm/cpu-ppc.h

@@ -5,8 +5,6 @@ register CELL ds asm("r14");
 register CELL rs asm("r15");
 
 void c_to_factor(CELL quot);
-void docol_profiling(CELL word);
-void docol(CELL word);
 void undefined(CELL word);
 void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
 void throw_impl(CELL quot, F_STACK_FRAME *rewind);

vm/cpu-x86.S

@@ -18,22 +18,12 @@ DEF(F_FASTCALL void,undefined,(CELL word)):
 	mov STACK_REG,ARG1                    /* Pass callstack pointer */
 	jmp MANGLE(undefined_error)           /* This throws an error */
 
-/* Here we have two entry points. The first one is taken when profiling is
-enabled */
-DEF(F_FASTCALL void,docol_profiling,(CELL word)):
-	add $8,PROFILING_OFFSET(ARG0)         /* Increment profile-count slot */
-DEF(F_FASTCALL void,docol,(CELL word)):
-	mov WORD_DEF_OFFSET(ARG0),ARG0        /* Load word-def slot */
-	JUMP_QUOT
-
-/* We must pass the XT to the quotation in ECX. */
 DEF(F_FASTCALL void,primitive_call,(void)):
         mov (DS_REG),ARG0                     /* Load quotation from data stack */
 	sub $CELL_SIZE,DS_REG                 /* Pop data stack */
 	JUMP_QUOT
 
-/* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the
+/* Don't mess up EDX, it's the callstack top parameter to primitives. */
-callstack top parameter to primitives. */
 DEF(F_FASTCALL void,primitive_execute,(void)):
 	mov (DS_REG),ARG0                     /* Load word from data stack */
 	sub $CELL_SIZE,DS_REG                 /* Pop data stack */

vm/cpu-x86.h

@@ -5,8 +5,6 @@ INLINE void flush_icache(CELL start, CELL len) {}
 F_FASTCALL void c_to_factor(CELL quot);
 F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
 F_FASTCALL void undefined(CELL word);
-F_FASTCALL void docol_profiling(CELL word);
-F_FASTCALL void docol(CELL word);
 F_FASTCALL void lazy_jit_compile(CELL quot);
 
 void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);

vm/factor.c

@@ -54,7 +54,7 @@ void do_stage1_init(void)
 	/* End heap scan */
 	gc_off = false;
 
-	iterate_code_heap(finalize_code_block);
+	iterate_code_heap(relocate_code_block);
 
 	userenv[STAGE2_ENV] = T;
 

vm/profiler.c

@@ -27,7 +27,7 @@ void set_profiling(bool profiling)
 	/* Push everything to tenured space so that we can heap scan */
 	data_gc();
 
-	/* Step 1 - Update word XTs and saved callstack objects */
+	/* Update word XTs and saved callstack objects */
 	begin_scan();
 
 	CELL obj;
@@ -39,11 +39,8 @@ void set_profiling(bool profiling)
 
 	gc_off = false; /* end heap scan */
 
-	/* Step 2 - Update XTs in code heap */
+	/* Update XTs in code heap */
 	iterate_code_heap(relocate_code_block);
-
-	/* Step 3 - flush instruction cache */
-	flush_icache(code_heap.segment->start,code_heap.segment->size);
 }
 
 DEFINE_PRIMITIVE(profiling)

vm/quotations.c

@@ -236,7 +236,7 @@ void jit_compile(CELL quot)
 		untag_object(words),
 		untag_object(literals));
 
-	iterate_code_heap_step(compiled,finalize_code_block);
+	iterate_code_heap_step(compiled,relocate_code_block);
 
 	set_quot_xt(untag_object(quot),compiled);
 

vm/types.c

@@ -234,6 +234,42 @@ DEFINE_PRIMITIVE(array_to_vector)
 	dpush(tag_object(vector));
 }
 
+F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+{
+	REGISTER_ROOT(elt);
+
+	if(*result_count == array_capacity(result))
+	{
+		result = reallot_array(result,
+			*result_count * 2,F);
+	}
+
+	UNREGISTER_ROOT(elt);
+	set_array_nth(result,*result_count,elt);
+	*result_count = *result_count + 1;
+
+	return result;
+}
+
+F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+{
+	REGISTER_UNTAGGED(elts);
+
+	CELL elts_size = array_capacity(elts);
+	CELL new_size = *result_count + elts_size;
+
+	if(new_size >= array_capacity(result))
+		result = reallot_array(result,new_size * 2,F);
+
+	UNREGISTER_UNTAGGED(elts);
+
+	memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+
+	*result_count += elts_size;
+
+	return result;
+}
+
 /* untagged */
 F_STRING* allot_string_internal(CELL capacity)
 {

vm/types.h

@@ -201,44 +201,12 @@ DECLARE_PRIMITIVE(wrapper);
 	CELL result##_count = 0; \
 	CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
 
-INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count);
-{
-	REGISTER_ROOT(elt);
-
-	if(*result_count == array_capacity(result))
-	{
-		result = reallot_array(result,
-			*result_count * 2,F);
-	}
-
-	UNREGISTER_ROOT(elt);
-	set_array_nth(result,*result_count,elt);
-	*result_count = *result_count + 1;
-
-	return result;
-}
 
 #define GROWABLE_ADD(result,elt) \
 	result = tag_object(growable_add(untag_object(result),elt,&result##_count))
 
-INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
-{
-	REGISTER_UNTAGGED(elts);
-
-	CELL elts_size = array_capacity(elts);
-	CELL new_size = *result_count + elts_size;
-
-	if(new_size >= array_capacity(result))
-		result = reallot_array(result,new_size * 2,F);
-
-	UNREGISTER_UNTAGGED(elts);
-
-	memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
-
-	*result_count += elts_size;
-
-	return result;
-}
 
 #define GROWABLE_APPEND(result,elts) \
 	result = tag_object(growable_append(untag_object(result),elts,&result##_count))