Fix 'bad XT' error

TODO.FACTOR.txt

@@ -1,12 +1,13 @@
 + 0.84:
 
-- RT_WORD should refer to XTs not word objects.
+- win32? . ==> t on intel mac??
 - signal 4 on datastack underflow on mac intel??
 
 ========================================================================
 
 + ui:
 
+- x11: scroll up/down wiggles caret
 - perhaps commands window should sort by gesture
 - new section in cookbook: philosophy
 - interactor commands: don't invoke if interactor is busy

library/compiler/generator/generator.factor

@@ -42,7 +42,8 @@ UNION: #terminal
 : init-generator ( -- )
     V{ } clone relocation-table set
     V{ } clone literal-table set
-    V{ } clone label-table set ;
+    V{ } clone label-table set 
+    V{ } clone word-table set ;
 
 : generate-1 ( word node quot -- )
     #! Generate the code, then dump three vectors to pass to
@@ -54,6 +55,7 @@ UNION: #terminal
         generate-labels
         relocation-table get
         literal-table get
+        word-table get
     ] V{ } make
     code-format add-compiled-block save-xt ;
 ! 

library/compiler/generator/xt.factor

@@ -23,14 +23,20 @@ SYMBOL: compiled-xts
 : save-xt ( word xt -- )
     swap dup unchanged-word compiled-xts get set-hash ;
 
+: push-new* ( obj table -- n )
+    2dup [ eq? ] find-with drop dup -1 > [
+        2nip
+    ] [
+        drop dup length >r push r>
+    ] if ;
+
 SYMBOL: literal-table
 
-: add-literal ( obj -- n )
+: add-literal ( obj -- n ) literal-table get push-new* ;
-    dup literal-table get [ eq? ] find-with drop dup -1 > [
+
-        nip
+SYMBOL: word-table
-    ] [
+
-        drop literal-table get dup length >r push r>
+: add-word ( word -- n ) word-table get push-new* ;
-    ] if ;
 
 SYMBOL: relocation-table
 SYMBOL: label-table
@@ -61,7 +67,7 @@ SYMBOL: label-table
 
 : rel-word ( word class -- )
     over primitive?
-    [ >r word-primitive r> 0 ] [ >r add-literal r> 5 ] if
+    [ >r word-primitive r> 0 ] [ >r add-word r> 5 ] if
     rel, ;
 
 : rel-cards ( class -- ) 0 swap 3 rel, ;

library/compiler/inference/known-words.factor

@@ -250,7 +250,7 @@ t over set-effect-terminated?
 \ cwd { } { string } <effect> "infer-effect" set-word-prop
 \ cd { string } { } <effect> "infer-effect" set-word-prop
 
-\ add-compiled-block { vector vector vector integer } { integer } <effect> "infer-effect" set-word-prop
+\ add-compiled-block { vector vector vector vector integer } { integer } <effect> "infer-effect" set-word-prop
 
 \ dlopen { string } { dll } <effect> "infer-effect" set-word-prop
 \ dlsym { string object } { integer } <effect> "infer-effect" set-word-prop

library/test/kernel.factor

@@ -1,6 +1,6 @@
 IN: scratchpad
 USING: kernel kernel-internals math memory namespaces sequences
-test quotations ;
+test ;
 
 [ 0 ] [ f size ] unit-test
 [ t ] [ [ \ = \ = ] all-equal? ] unit-test

vm/compiler.c

@@ -9,11 +9,14 @@ void iterate_code_heap(CELL start, CELL end, CODE_HEAP_ITERATOR iter)
 		CELL code_start = start + sizeof(F_COMPILED);
 		CELL reloc_start = code_start + compiled->code_length;
 		CELL literal_start = reloc_start + compiled->reloc_length;
-		CELL literal_end = literal_start + compiled->literal_length;
+		CELL words_start = literal_start + compiled->literal_length;
+		CELL words_end = words_start + compiled->words_length;
 
-		iter(compiled,code_start,reloc_start,literal_start,literal_end);
+		iter(compiled,
+			code_start,reloc_start,
+			literal_start,words_start);
 
-		start = literal_end;
+		start = words_end;
 	}
 }
 
@@ -22,11 +25,11 @@ void undefined_symbol(void)
 	general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
 }
 
-#define LITERAL_REF(literal_start,num) ((literal_start) + CELLS * (num))
+#define CREF(array,i) ((CELL)(array) + CELLS * (i))
 
 INLINE CELL get_literal(CELL literal_start, CELL num)
 {
-	return get(LITERAL_REF(literal_start,num));
+	return get(CREF(literal_start,num));
 }
 
 CELL get_rel_symbol(F_REL *rel, CELL literal_start)
@@ -48,17 +51,8 @@ CELL get_rel_symbol(F_REL *rel, CELL literal_start)
 	return sym;
 }
 
-CELL get_rel_word(F_REL *rel, CELL literal_start)
-{
-	CELL arg = REL_ARGUMENT(rel);
-	F_WORD *word = untag_word(get_literal(literal_start,arg));
-	if(word->xt < compiling.base || word->xt >= compiling.limit)
-		critical_error("Bad XT",tag_word(word));
-	return word->xt;
-}
-
 INLINE CELL compute_code_rel(F_REL *rel,
-	CELL code_start, CELL literal_start)
+	CELL code_start, CELL literal_start, CELL words_start)
 {
 	CELL offset = code_start + rel->offset;
 
@@ -73,9 +67,9 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_CARDS:
 		return cards_offset;
 	case RT_LITERAL:
-		return LITERAL_REF(literal_start,REL_ARGUMENT(rel));
+		return CREF(literal_start,REL_ARGUMENT(rel));
-	case RT_WORD:
+	case RT_XT:
-		return get_rel_word(rel,literal_start);
+		return get(CREF(words_start,REL_ARGUMENT(rel)));
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -97,15 +91,15 @@ INLINE void reloc_set_masked(CELL cell, CELL value, CELL mask)
 	*(u32*)cell = (original | (value & mask));
 }
 
-void apply_relocation(F_REL *rel, CELL code_start, CELL literal_start)
+void apply_relocation(F_REL *rel,
+	CELL code_start, CELL literal_start, CELL words_start)
 {
 	CELL absolute_value;
 	CELL relative_value;
 	CELL offset = rel->offset + code_start;
 
-	/* to_c_string can fill up the heap */
+	absolute_value = compute_code_rel(rel,
-	maybe_gc(0);
+		code_start,literal_start,words_start);
-	absolute_value = compute_code_rel(rel,code_start,literal_start);
 	relative_value = absolute_value - offset;
 
 	switch(REL_CLASS(rel))
@@ -138,23 +132,46 @@ void apply_relocation(F_REL *rel, CELL code_start, CELL literal_start)
 }
 
 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literal_start, CELL literal_end)
+	CELL reloc_start, CELL literal_start, CELL words_start)
 {
+	CELL words_end = words_start + relocating->words_length;
+
 	F_REL *rel = (F_REL *)reloc_start;
 	F_REL *rel_end = (F_REL *)literal_start;
 
+	if(!relocating->finalized)
+	{
+		/* first time (ie, we just compiled, and are not simply loading
+		an image from disk). figure out word XTs. */
+		CELL scan;
+		
+		for(scan = words_start; scan < words_end; scan += CELLS)
+			put(scan,untag_word(get(scan))->xt);
+
+		relocating->finalized = true;
+	}
+
 	/* apply relocations */
 	while(rel < rel_end)
-		apply_relocation(rel++,code_start,literal_start);
+		apply_relocation(rel++,code_start,literal_start,words_start);
 }
 
 void collect_literals_step(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literal_start, CELL literal_end)
+	CELL reloc_start, CELL literal_start, CELL words_start)
 {
 	CELL scan;
 	
+	CELL literal_end = literal_start + relocating->literal_length;
+	CELL words_end = words_start + relocating->words_length;
+	
 	for(scan = literal_start; scan < literal_end; scan += CELLS)
 		copy_handle((CELL*)scan);
+
+	for(scan = words_start; scan < words_end; scan += CELLS)
+	{
+		if(!relocating->finalized)
+			copy_handle((CELL*)scan);
+	}
 }
 
 void collect_literals(void)
@@ -181,17 +198,12 @@ void deposit_integers(F_VECTOR *vector, CELL format)
 	if(format == 1)
 	{
 		for(i = 0; i < count; i++)
-			cput(compiling.here + i,to_fixnum(get(AREF(array,i))));
+			cput(CREF(compiling.here,i),to_fixnum(get(AREF(array,i))));
 	}
 	else if(format == CELLS)
 	{
-		CELL dest = compiling.here;
-
 		for(i = 0; i < count; i++)
-		{
+			put(CREF(compiling.here,i),to_fixnum(get(AREF(array,i))));
-			put(dest,to_fixnum(get(AREF(array,i))));
-			dest += CELLS;
-		}
 	}
 	else
 		critical_error("Bad format param to deposit_vector()",format);
@@ -203,19 +215,24 @@ void deposit_objects(F_VECTOR *vector, CELL literal_length)
 	memcpy((void*)compiling.here,array + 1,literal_length);
 }
 
-void add_compiled_block(CELL code_format, F_VECTOR *code,
+CELL add_compiled_block(CELL code_format, F_VECTOR *code,
-	F_VECTOR *literals, F_VECTOR *rel)
+	F_VECTOR *literals, F_VECTOR *words, F_VECTOR *rel)
 {
 	CELL start = compiling.here;
+
 	CELL code_length = align8(untag_fixnum_fast(code->top) * code_format);
 	CELL rel_length = untag_fixnum_fast(rel->top) * CELLS;
 	CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
+	CELL words_length = untag_fixnum_fast(words->top) * CELLS;
 
 	/* compiled header */
 	F_COMPILED header;
 	header.code_length = code_length;
 	header.reloc_length = rel_length;
 	header.literal_length = literal_length;
+	header.words_length = words_length;
+	header.finalized = false;
+
 	memcpy((void*)compiling.here,&header,sizeof(F_COMPILED));
 	compiling.here += sizeof(F_COMPILED);
 	
@@ -231,18 +248,23 @@ void add_compiled_block(CELL code_format, F_VECTOR *code,
 	deposit_objects(literals,literal_length);
 	compiling.here += literal_length;
 
-	/* push the XT of the new word on the stack */
+	/* words */
-	box_unsigned_cell(start + sizeof(F_COMPILED));
+	deposit_objects(words,words_length);
+	compiling.here += words_length;
+
+	return start + sizeof(F_COMPILED);
 }
 
 void primitive_add_compiled_block(void)
 {
 	CELL code_format = to_cell(dpop());
 	F_VECTOR *code = untag_vector(dpop());
+	F_VECTOR *words = untag_vector(dpop());
 	F_VECTOR *literals = untag_vector(dpop());
 	F_VECTOR *rel = untag_vector(dpop());
 
-	add_compiled_block(code_format,code,literals,rel);
+	/* push the XT of the new word on the stack */
+	box_unsigned_cell(add_compiled_block(code_format,code,literals,words,rel));
 }
 
 void primitive_finalize_compile(void)

vm/compiler.h

@@ -4,10 +4,12 @@ typedef struct
 	CELL code_length; /* # bytes */
 	CELL reloc_length; /* # bytes */
 	CELL literal_length; /* # bytes */
+	CELL words_length; /* # bytes */
+	CELL finalized; /* has finalize_code_block() been called on this yet? */
 } F_COMPILED;
 
 typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
-	CELL reloc_start, CELL literal_start, CELL literal_end);
+	CELL reloc_start, CELL literal_start, CELL words_start);
 
 void iterate_code_heap(CELL start, CELL end, CODE_HEAP_ITERATOR iter);
 
@@ -22,8 +24,8 @@ typedef enum {
 	RT_CARDS,
 	/* an indirect literal from the word's literal table */
 	RT_LITERAL,
-	/* a word */
+	/* a compiled word reference */
-	RT_WORD,
+	RT_XT,
 	/* a local label */
 	RT_LABEL
 } F_RELTYPE;
@@ -52,7 +54,7 @@ typedef struct {
 } F_REL;
 
 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literal_start, CELL literal_end);
+	CELL reloc_start, CELL literal_start, CELL words_start);
 
 void collect_literals(void);
 

vm/image.c

@@ -172,16 +172,26 @@ void relocate_data()
 }
 
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literal_start, CELL literal_end)
+	CELL reloc_start, CELL literal_start, CELL words_start)
 {
 	/* relocate literal table data */
 	CELL scan;
+	CELL literal_end = literal_start + relocating->literal_length;
+	CELL words_end = words_start + relocating->words_length;
 
 	for(scan = literal_start; scan < literal_end; scan += CELLS)
 		data_fixup((CELL*)scan);
 
+	for(scan = words_start; scan < words_end; scan += CELLS)
+	{
+		if(relocating->finalized)
+			code_fixup((CELL*)scan);
+		else
+			data_fixup((CELL*)scan);
+	}
+
 	finalize_code_block(relocating,code_start,reloc_start,
-		literal_start,literal_end);
+		literal_start,words_start);
 }
 
 void relocate_code()

vm/os-macosx.m

@@ -4,6 +4,7 @@
 #import "Foundation/NSBundle.h"
 #import "Foundation/NSException.h"
 #import "Foundation/NSString.h"
+#import "Foundation/NSPathUtilities.h"
 
 static CELL error;