More generator/relocator fixes

library/compiler/generator/generator.factor

@@ -55,7 +55,7 @@ UNION: #terminal
         generate-code
         relocation-table get
         literal-table get
-        label-table get
+        label-table get [ label-offset ] map
         label-relocation-table get
     ] V{ } make
     code-format add-compiled-block save-xt ;

library/compiler/generator/xt.factor

@@ -5,27 +5,27 @@ USING: arrays assembler errors generic hashtables kernel
 kernel-internals math namespaces prettyprint queues
 sequences strings vectors words ;
 
-: compiled ( -- n ) building get length code-format * ;
+: compiled-offset ( -- n ) building get length code-format * ;
 
 TUPLE: label # offset ;
 
 SYMBOL: label-table
 
 : push-label ( label -- )
-    label-table get 2dup memq?
+    label-table get dup length pick set-label-# push ;
-    [ 2drop ] [ dup length pick set-label-# push ] if ;
 
-C: label ( -- label ) ;
+C: label ( -- label )
+    compiled-offset over set-label-offset dup push-label ;
 
 : define-label ( name -- ) <label> swap set ;
 
 : resolve-label ( label -- )
-    compiled swap set-label-offset ;
+    compiled-offset swap set-label-offset ;
 
 SYMBOL: compiled-xts
 
-: save-xt ( word -- )
+: save-xt ( word xt -- )
-    compiled swap compiled-xts get set-hash ;
+    swap compiled-xts get set-hash ;
 
 : commit-xts ( -- )
     compiled-xts get [ swap set-word-xt ] hash-each ;
@@ -54,13 +54,13 @@ SYMBOL: label-relocation-table
     #! Write a relocation instruction for the runtime image
     #! loader.
     over >r >r >r 16 shift r> 8 shift bitor r> bitor
-    compiled r> rel-absolute-cell = cell 4 ? - 2array ;
+    compiled-offset r> rel-absolute-cell = cell 4 ? - 2array ;
 
 : rel, ( arg class type -- )
-    (rel) relocation-table get nappend ;
+    (rel) relocation-table get swap nappend ;
 
 : label, ( arg class type -- )
-    (rel) label-relocation-table get nappend ;
+    (rel) label-relocation-table get swap nappend ;
 
 : rel-dlsym ( name dll class -- )
    >r 2array add-literal r> 1 rel, ;
@@ -79,7 +79,7 @@ SYMBOL: label-relocation-table
     >r add-literal r> 4 rel, ;
 
 : rel-label ( label class -- )
-    >r dup push-label label-# r> 5 label, ;
+    >r label-# r> 6 label, ;
 
 ! When a word is encountered that has not been previously
 ! compiled, it is pushed onto this vector. Compilation stops

vm/image.c

@@ -237,7 +237,7 @@ INLINE CELL compute_code_rel(F_REL *rel,
 		if(labels == NULL)
 			critical_error("RT_LABEL can only appear in label-relocation-table",0);
 
-		return to_fixnum(get(AREF(array,REL_ARGUMENT(rel))))
+		return to_cell(get(AREF(array,REL_ARGUMENT(rel))))
 			+ code_start;
 	default:
 		critical_error("Unsupported rel type",rel->type);
@@ -249,69 +249,41 @@ void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
 	F_VECTOR *labels)
 {
 	CELL original;
-	CELL new_value;
+	CELL absolute_value;
+	CELL relative_value;
 	CELL offset = rel->offset + code_start;
 
-	switch(REL_CLASS(rel))
-	{
-	case REL_ABSOLUTE_CELL:
-		original = get(offset);
-		break;
-	case REL_ABSOLUTE:
-		original = *(u32*)offset;
-		break;
-	case REL_RELATIVE:
-		original = *(u32*)offset - (offset + sizeof(u32));
-		break;
-	case REL_ABSOLUTE_2_2:
-		original = reloc_get_2_2(offset);
-		break;
-	case REL_RELATIVE_2_2:
-		original = reloc_get_2_2(offset) - (offset + sizeof(u32));
-		break;
-	case REL_RELATIVE_2:
-		original = *(u32*)offset;
-		original &= REL_RELATIVE_2_MASK;
-		break;
-	case REL_RELATIVE_3:
-		original = *(u32*)offset;
-		original &= REL_RELATIVE_3_MASK;
-		break;
-	default:
-		critical_error("Unsupported rel class",REL_CLASS(rel));
-		return;
-	}
-
 	/* to_c_string can fill up the heap */
 	maybe_gc(0);
-	new_value = compute_code_rel(rel,code_start,literal_start,labels);
+	absolute_value = compute_code_rel(rel,code_start,literal_start,labels);
+	relative_value = absolute_value - offset;
 
 	switch(REL_CLASS(rel))
 	{
 	case REL_ABSOLUTE_CELL:
-		put(offset,new_value);
+		put(offset,absolute_value);
 		break;
 	case REL_ABSOLUTE:
-		*(u32*)offset = new_value;
+		*(u32*)offset = absolute_value;
 		break;
 	case REL_RELATIVE:
-		*(u32*)offset = new_value - (offset + sizeof(u32));
+		*(u32*)offset = relative_value - sizeof(u32);
 		break;
 	case REL_ABSOLUTE_2_2:
-		reloc_set_2_2(offset,new_value);
+		reloc_set_2_2(offset,absolute_value);
 		break;
 	case REL_RELATIVE_2_2:
-		reloc_set_2_2(offset,new_value - (offset + sizeof(u32)));
+		reloc_set_2_2(offset,relative_value);
 		break;
 	case REL_RELATIVE_2:
 		original = *(u32*)offset;
 		original &= ~REL_RELATIVE_2_MASK;
-		*(u32*)offset = (original | new_value);
+		*(u32*)offset = (original | relative_value);
 		break;
 	case REL_RELATIVE_3:
 		original = *(u32*)offset;
 		original &= ~REL_RELATIVE_3_MASK;
-		*(u32*)offset = (original | new_value);
+		*(u32*)offset = (original | relative_value);
 		break;
 	default:
 		critical_error("Unsupported rel class",REL_CLASS(rel));

vm/image.h

@@ -66,8 +66,8 @@ typedef enum {
 #define REL_RELATIVE_2 5
 #define REL_RELATIVE_3 6
 
-#define REL_RELATIVE_2_MASK 0x3fffffc
+#define REL_RELATIVE_2_MASK 0xfffc
-#define REL_RELATIVE_3_MASK 0xfffc
+#define REL_RELATIVE_3_MASK 0x3fffffc
 
 /* the rel type is built like a cell to avoid endian-specific code in
 the compiler */
@@ -95,13 +95,6 @@ void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
 CELL relocate_code_next(CELL relocating);
 void relocate_code();
 
-/* on PowerPC, return the 32-bit literal being loaded at the code at the
-given address */
-INLINE CELL reloc_get_2_2(CELL cell)
-{
-	return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
-}
-
 INLINE void reloc_set_2_2(CELL cell, CELL value)
 {
 	put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));

vm/run.c

@@ -322,7 +322,7 @@ void deposit_vector(F_VECTOR *vector, CELL format)
 void fixup_labels(F_VECTOR *label_rel, CELL code_start, CELL literal_start,
 	F_VECTOR *labels)
 {
-	F_ARRAY *array = untag_array_fast(labels->array);
+	F_ARRAY *array = untag_array_fast(label_rel->array);
 	CELL length = untag_fixnum_fast(label_rel->top);
 	CELL i;