64-bit relocation

library/compiler/amd64/architecture.factor

@@ -21,7 +21,8 @@ sequences ;
 : param-regs { RDI RSI RDX RCX R8 R9 } ; inline
 
 : compile-c-call ( symbol dll -- )
-    2dup dlsym 0 scratch swap MOV 0 0 rel-dlsym 0 scratch CALL ;
+    2dup dlsym 0 scratch swap MOV
+    rel-absolute-cell rel-dlsym 0 scratch CALL ;
 
 : compile-c-call* ( symbol dll -- operands )
     param-regs swap [ MOV ] 2each compile-c-call ;

library/compiler/assembler.factor

@@ -4,6 +4,8 @@ IN: assembler
 USING: alien generic hashtables kernel kernel-internals lists
 math memory namespaces ;
 
+: compiled-base 18 getenv ; inline
+
 : compiled-header HEX: 01c3babe ; inline
 
 : set-compiled-1 ( n a -- ) f swap set-alien-signed-1 ; inline

library/compiler/ppc/generator.factor

@@ -5,7 +5,7 @@ USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces words ;
 
 : compile-dlsym ( symbol dll register -- )
-    >r 2dup dlsym  r> LOAD32 0 1 rel-dlsym ;
+    >r 2dup dlsym  r> LOAD32 rel-2-2 rel-dlsym ;
 
 : compile-c-call ( symbol dll -- )
     11 [ compile-dlsym ] keep MTLR  BLRL ;
@@ -31,14 +31,14 @@ M: %call-label generate-node ( vop -- )
     #! Near calling convention for inlined recursive combinators
     #! Note: length of instruction sequence is hard-coded.
     vop-label
-    compiled-offset 20 + 18 LOAD32  0 1 rel-address
+    compiled-offset 20 + 18 LOAD32  rel-2/2 rel-address
     1 1 stack-increment neg STWU
     18 1 stack-increment lr@ STW
     B ;
 
 : word-addr ( word -- )
     #! Load a word address into r3.
-    dup word-xt 3 LOAD32  0 1 rel-word ;
+    dup word-xt 3 LOAD32  rel-2/2 rel-word ;
 
 : compile-call ( label -- )
     #! Far C call for primitives, near C call for compiled defs.
@@ -84,7 +84,7 @@ M: %dispatch generate-node ( vop -- )
     0 input-operand dup 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    compiled-offset 24 + 0 scratch LOAD32  0 1 rel-address
+    compiled-offset 24 + 0 scratch LOAD32  rel-2/2 rel-address
     0 input-operand dup 0 scratch ADD
     0 input-operand dup 0 LWZ
     0 input-operand MTLR

library/compiler/ppc/slots.factor

@@ -56,7 +56,7 @@ M: %set-char-slot generate-node ( vop -- )
 
 : userenv ( reg -- )
     #! Load the userenv pointer in a virtual register.
-    "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
+    "userenv" f dlsym swap LOAD32 rel-2/2 rel-userenv ;
 
 M: %getenv generate-node ( vop -- )
     drop 0 output-operand dup dup userenv 0 input cell * LWZ ;

library/compiler/ppc/stack.factor

@@ -13,7 +13,7 @@ M: %immediate generate-node ( vop -- )
     drop 0 input address 0 output-operand LOAD ;
 
 : load-indirect ( dest literal -- )
-    add-literal over LOAD32 0 1 rel-address dup 0 LWZ ;
+    add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
 
 M: %indirect generate-node ( vop -- )
     drop 0 output-operand 0 input load-indirect ;

library/compiler/x86/architecture.factor

@@ -19,7 +19,7 @@ sequences ;
 : vregs { EAX ECX EDX } ; inline
 
 : compile-c-call ( symbol dll -- )
-    2dup dlsym CALL 1 0 rel-dlsym ;
+    2dup dlsym CALL rel-relative rel-dlsym ;
 
 : compile-c-call* ( symbol dll args -- operands )
     reverse-slice

library/compiler/x86/slots.factor

@@ -26,7 +26,7 @@ M: %write-barrier generate-node ( vop -- )
     #! sacrificing a few bytes of generated code size.
     drop
     0 input-operand card-bits SHR
-    0 scratch card-offset MOV 0 rel-cards
+    0 scratch card-offset MOV rel-absolute-cell rel-cards
     0 scratch 0 input-operand ADD
     0 scratch 1array card-mark OR ;
 
@@ -47,11 +47,11 @@ M: %fast-set-slot generate-node ( vop -- )
 M: %getenv generate-node ( vop -- )
     drop
     0 output-operand 0 input userenv@ MOV
-    0 input 0 rel-userenv
+    0 input rel-absolute-cell rel-userenv
     0 output-operand dup 1array MOV ;
 
 M: %setenv generate-node ( vop -- )
     drop
     0 scratch 1 input userenv@ MOV
-    1 input 0 rel-userenv
+    1 input rel-absolute-cell rel-userenv
     0 scratch 1array 0 input-operand MOV ;

library/compiler/x86/stack.factor

@@ -26,7 +26,8 @@ M: %immediate generate-node ( vop -- )
     drop 0 output-operand 0 input address MOV ;
 
 : load-indirect ( dest literal -- )
-    add-literal address-operand 1array MOV 0 0 rel-address ;
+    add-literal address-operand 1array MOV
+    rel-absolute-cell rel-address ;
 
 M: %indirect generate-node ( vop -- )
     #! indirect load of a literal through a table

library/compiler/xt.factor

@@ -38,29 +38,34 @@ SYMBOL: relocation-table
 
 : 4-just-compiled compiled-offset 4 - ;
 
-: relocating cell-just-compiled rel, ;
+: rel-absolute-cell 0 ;
+: rel-absolute 1 ;
+: rel-relative 2 ;
+: rel-2/2 3 ;
 
-: rel-type, ( rel/abs 16/16 type -- )
+: rel-type, ( arg class type -- )
-    swap 8 shift bitor swap 16 shift bitor rel, ;
+    #! Write a relocation instruction for the runtime image
+    #! loader.
+    >r >r 16 shift r> 8 shift bitor r> bitor rel,
+    cell-just-compiled rel, ;
 
-: rel-primitive ( word relative 16/16 -- )
+: rel-dlsym ( name dll class -- )
-    0 rel-type, relocating word-primitive rel, ;
+    >r cons add-literal compiled-base - cell / r> 1 rel-type, ;
 
-: rel-dlsym ( name dll rel/abs 16/16 -- )
+: rel-address ( class -- )
-    1 rel-type, relocating cons add-literal rel, ;
-
-: rel-address ( rel/abs 16/16 -- )
     #! Relocate address just compiled.
-    over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ;
+    dup rel-relative = [ 2drop ] [ 0 -rot 2 rel-type, ] if ;
 
-: rel-word ( word rel/abs 16/16 -- )
+: rel-word ( word class -- )
-    pick primitive? [ rel-primitive ] [ rel-address drop ] if ;
+    over primitive? [
+        >r word-primitive r> 0 rel-type,
+    ] [
+        rel-address drop
+    ] if ;
 
-: rel-userenv ( n 16/16 -- )
+: rel-userenv ( n class -- ) 3 rel-type, ;
-    0 swap 3 rel-type, relocating rel, ;
 
-: rel-cards ( 16/16 -- )
+: rel-cards ( class -- ) 4 rel-type, ;
-    0 swap 4 rel-type, relocating 0 rel, ;
 
 ! This is for fixing up forward references
 GENERIC: resolve ( fixup -- addr )
@@ -123,32 +128,35 @@ M: fixup-2/2 fixup ( addr fixup -- )
     fixup-2/2-at >r w>h/h r> tuck 4 - or-compiled or-compiled ;
 
 : relative-4 ( word -- )
-    dup 1 0 rel-word ( FIXME)
+    dup rel-relative rel-word
     compiled-offset <relative>
     4-just-compiled <fixup-4> deferred-xt ;
 
 : relative-3 ( word -- )
+    #! Labels only -- no image relocation information saved
     4-just-compiled <relative>
     4-just-compiled <fixup-3> deferred-xt ;
 
 : relative-2 ( word -- )
+    #! Labels only -- no image relocation information saved
     4-just-compiled <relative>
     4-just-compiled <fixup-2> deferred-xt ;
 
 : relative-2/2 ( word -- )
+    #! Labels only -- no image relocation information saved
     compiled-offset <relative>
     4-just-compiled <fixup-2/2> deferred-xt ;
 
 : absolute-4 ( word -- )
-    dup 0 0 rel-word ( FIXME)
+    dup rel-absolute rel-word
     <absolute> 4-just-compiled <fixup-4> deferred-xt ;
 
 : absolute-2/2 ( word -- )
-    dup 0 1 rel-word
+    dup rel-2/2 rel-word
     <absolute> cell-just-compiled <fixup-2/2> deferred-xt ;
 
 : absolute-cell ( word -- )
-    dup 0 0 rel-word
+    dup rel-absolute-cell rel-word
     <absolute> cell-just-compiled <fixup-cell> deferred-xt ;
 
 ! When a word is encountered that has not been previously

library/syntax/parse-stream.factor

@@ -17,10 +17,10 @@ USING: errors io kernel lists math namespaces sequences words ;
 : parse-stream ( stream name -- quot )
     [ file set file-vocabs lines parse-lines ] with-scope ;
 
-: parsing-file ( file -- ) "! " write dup print ;
+: parsing-file ( file -- ) "! Loading " write print ;
 
 : parse-file ( file -- quot )
-    parsing-file
+    dup parsing-file
     [ <file-reader> ] keep parse-stream ;
 
 : run-file ( file -- )
@@ -33,7 +33,7 @@ USING: errors io kernel lists math namespaces sequences words ;
     #! resource:. This allows words that operate on source
     #! files, like "jedit", to use a different resource path
     #! at run time than was used at parse time.
-    parsing-file
+    dup parsing-file
     [ <resource-stream> "resource:" ] keep append parse-stream ;
 
 : run-resource ( file -- )

native/factor.c

@@ -22,6 +22,7 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
 	userenv[CARD_OFF_ENV] = tag_cell(cards_offset);
 	userenv[IMAGE_ENV] = tag_object(from_c_string(image));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
+	userenv[COMPILED_BASE_ENV] = tag_cell(compiling.base);
 }
 
 INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
@@ -59,7 +60,6 @@ int main(int argc, char** argv)
 		printf(" +Yn   Size of n-1 youngest generations, megabytes\n");
 		printf(" +An   Size of tenured and semi-spaces, megabytes\n");
 		printf(" +Xn   Code heap size, megabytes\n");
-		printf(" +Ln   Literal table size, kilobytes. Only for bootstrapping\n");
 		printf("Other options are handled by the Factor library.\n");
 		printf("See the documentation for details.\n");
 		printf("Send bug reports to Slava Pestov <slava@jedit.org>.\n");
@@ -74,7 +74,6 @@ int main(int argc, char** argv)
 		if(factor_arg(argv[i],"+Y%d",&young_size)) continue;
 		if(factor_arg(argv[i],"+A%d",&aging_size)) continue;
 		if(factor_arg(argv[i],"+X%d",&code_size)) continue;
-		if(factor_arg(argv[i],"+L%d",&literal_size)) continue;
 
 		if(strncmp(argv[i],"+",1) == 0)
 		{

native/relocate.c

@@ -92,7 +92,8 @@ void undefined_symbol(void)
 
 CELL get_rel_symbol(F_REL* rel)
 {
-	F_CONS* cons = untag_cons(get(rel->argument));
+	CELL arg = REL_ARGUMENT(rel);
+	F_CONS* cons = untag_cons(compiling.base + arg * sizeof(CELL));
 	F_STRING* symbol = untag_string(cons->car);
 	DLL* dll = (cons->cdr == F ? NULL : untag_dll(cons->cdr));
 	CELL sym;
@@ -113,18 +114,17 @@ INLINE CELL compute_code_rel(F_REL *rel, CELL original)
 	switch(REL_TYPE(rel))
 	{
 	case F_PRIMITIVE:
-		return primitive_to_xt(rel->argument);
+		return primitive_to_xt(REL_ARGUMENT(rel));
 	case F_DLSYM:
-		code_fixup(&rel->argument);
 		return get_rel_symbol(rel);
 	case F_ABSOLUTE:
 		return original + (compiling.base - code_relocation_base);
 	case F_USERENV:
-		return (CELL)&userenv[rel->argument];
+		return (CELL)&userenv[REL_ARGUMENT(rel)];
 	case F_CARDS:
 		return cards_offset;
 	default:
-		critical_error("Unsupported rel",rel->type);
+		critical_error("Unsupported rel type",rel->type);
 		return -1;
 	}
 }
@@ -152,22 +152,47 @@ INLINE CELL relocate_code_next(CELL relocating)
 
 		code_fixup(&rel->offset);
 		
-		if(REL_16_16(rel))
+		switch(REL_CLASS(rel))
-			original = reloc_get_16_16(rel->offset);
+		{
-		else
+		case REL_ABSOLUTE_CELL:
 			original = get(rel->offset);
+			break;
+		case REL_ABSOLUTE:
+			original = *(u32*)rel->offset;
+			break;
+		case REL_RELATIVE:
+			original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
+			break;
+		case REL_2_2:
+			original = reloc_get_2_2(rel->offset);
+			break;
+		default:
+			critical_error("Unsupported rel class",REL_CLASS(rel));
+			return -1;
+		}
 
 		/* to_c_string can fill up the heap */
 		maybe_gc(0);
 		new_value = compute_code_rel(rel,original);
 
-		if(REL_RELATIVE(rel))
+		switch(REL_CLASS(rel))
-			new_value -= (rel->offset + CELLS);
+		{
-
+		case REL_ABSOLUTE_CELL:
-		if(REL_16_16(rel))
-			reloc_set_16_16(rel->offset,new_value);
-		else
 			put(rel->offset,new_value);
+			break;
+		case REL_ABSOLUTE:
+			*(u32*)rel->offset = new_value;
+			break;
+		case REL_RELATIVE:
+			*(u32*)rel->offset = new_value - (rel->offset + CELLS);
+			break;
+		case REL_2_2:
+			reloc_set_2_2(rel->offset,new_value);
+			break;
+		default:
+			critical_error("Unsupported rel class",REL_CLASS(rel));
+			return -1;
+		}
 
 		rel++;
 	}

native/relocate.h

@@ -21,19 +21,21 @@ typedef enum {
 	F_CARDS
 } F_RELTYPE;
 
+#define REL_ABSOLUTE_CELL 0
+#define REL_ABSOLUTE 1
+#define REL_RELATIVE 2
+#define REL_2_2 3
+
 /* the rel type is built like a cell to avoid endian-specific code in
 the compiler */
-#define REL_TYPE(r) ((r)->type & 0xff)
+#define REL_TYPE(r) ((r)->type & 0x000000ff)
-/* on PowerPC, some values are stored in the high 16 bits of a pair
+#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
-of consecutive cells */
+#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
-#define REL_16_16(r) ((r)->type & 0xff00)
-#define REL_RELATIVE(r) ((r)->type & 0xff0000)
 
 /* code relocation consists of a table of entries for each fixup */
 typedef struct {
 	CELL type;
 	CELL offset;
-	CELL argument;
 } F_REL;
 
 CELL code_relocation_base;
@@ -48,12 +50,12 @@ void relocate_code();
 
 /* on PowerPC, return the 32-bit literal being loaded at the code at the
 given address */
-INLINE CELL reloc_get_16_16(CELL cell)
+INLINE CELL reloc_get_2_2(CELL cell)
 {
 	return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
 }
 
-INLINE void reloc_set_16_16(CELL cell, CELL value)
+INLINE void reloc_set_2_2(CELL cell, CELL value)
 {
 	put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
 	put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));

native/run.h

@@ -17,6 +17,7 @@
 #define GEN_ENV           15 /* set to gen_count */
 #define IMAGE_ENV         16 /* image name */
 #define CELL_SIZE_ENV     17 /* sizeof(CELL) */
+#define COMPILED_BASE_ENV 18 /* base of code heap */
 
 /* TAGGED user environment data; see getenv/setenv prims */
 DLLEXPORT CELL userenv[USER_ENV];