diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor index 6472779b49..973046996f 100644 --- a/library/compiler/amd64/architecture.factor +++ b/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 ; diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index fe35695e43..fcd6a91cb5 100644 --- a/library/compiler/assembler.factor +++ b/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 diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor index cc53d81fea..789f199dc9 100644 --- a/library/compiler/ppc/generator.factor +++ b/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 diff --git a/library/compiler/ppc/slots.factor b/library/compiler/ppc/slots.factor index 91a37e88db..65af9d6539 100644 --- a/library/compiler/ppc/slots.factor +++ b/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 ; diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor index 4d02ec223c..5768ef7e4c 100644 --- a/library/compiler/ppc/stack.factor +++ b/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 ; diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor index 27ead36788..4917bb76af 100644 --- a/library/compiler/x86/architecture.factor +++ b/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 diff --git a/library/compiler/x86/slots.factor b/library/compiler/x86/slots.factor index 8639bbac03..8579c8388f 100644 --- a/library/compiler/x86/slots.factor +++ b/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 ; diff --git a/library/compiler/x86/stack.factor b/library/compiler/x86/stack.factor index 7f208950e1..fa37e21935 100644 --- a/library/compiler/x86/stack.factor +++ b/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 diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index 96c943b5c4..e845f43ef3 100644 --- a/library/compiler/xt.factor +++ b/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 -- ) - swap 8 shift bitor swap 16 shift bitor rel, ; +: rel-type, ( arg class type -- ) + #! 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 -- ) - 0 rel-type, relocating word-primitive rel, ; +: rel-dlsym ( name dll class -- ) + >r cons add-literal compiled-base - cell / r> 1 rel-type, ; -: rel-dlsym ( name dll rel/abs 16/16 -- ) - 1 rel-type, relocating cons add-literal rel, ; - -: rel-address ( rel/abs 16/16 -- ) +: rel-address ( class -- ) #! 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 -- ) - pick primitive? [ rel-primitive ] [ rel-address drop ] if ; +: rel-word ( word class -- ) + over primitive? [ + >r word-primitive r> 0 rel-type, + ] [ + rel-address drop + ] if ; -: rel-userenv ( n 16/16 -- ) - 0 swap 3 rel-type, relocating rel, ; +: rel-userenv ( n class -- ) 3 rel-type, ; -: rel-cards ( 16/16 -- ) - 0 swap 4 rel-type, relocating 0 rel, ; +: rel-cards ( class -- ) 4 rel-type, ; ! 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 4-just-compiled deferred-xt ; : relative-3 ( word -- ) + #! Labels only -- no image relocation information saved 4-just-compiled 4-just-compiled deferred-xt ; : relative-2 ( word -- ) + #! Labels only -- no image relocation information saved 4-just-compiled 4-just-compiled deferred-xt ; : relative-2/2 ( word -- ) + #! Labels only -- no image relocation information saved compiled-offset 4-just-compiled deferred-xt ; : absolute-4 ( word -- ) - dup 0 0 rel-word ( FIXME) + dup rel-absolute rel-word 4-just-compiled deferred-xt ; : absolute-2/2 ( word -- ) - dup 0 1 rel-word + dup rel-2/2 rel-word cell-just-compiled deferred-xt ; : absolute-cell ( word -- ) - dup 0 0 rel-word + dup rel-absolute-cell rel-word cell-just-compiled deferred-xt ; ! When a word is encountered that has not been previously diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index aa2e2b3afd..2ce2c62630 100644 --- a/library/syntax/parse-stream.factor +++ b/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 [ ] 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:" ] keep append parse-stream ; : run-resource ( file -- ) diff --git a/native/factor.c b/native/factor.c index 1f3e03a420..125caa53d3 100644 --- a/native/factor.c +++ b/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 .\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) { diff --git a/native/relocate.c b/native/relocate.c index e2adba38b2..f750e54e0f 100644 --- a/native/relocate.c +++ b/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)) - original = reloc_get_16_16(rel->offset); - else + switch(REL_CLASS(rel)) + { + 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)) - new_value -= (rel->offset + CELLS); - - if(REL_16_16(rel)) - reloc_set_16_16(rel->offset,new_value); - else + switch(REL_CLASS(rel)) + { + case REL_ABSOLUTE_CELL: 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++; } diff --git a/native/relocate.h b/native/relocate.h index 0a16b3e7d3..1917d7072d 100644 --- a/native/relocate.h +++ b/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) -/* on PowerPC, some values are stored in the high 16 bits of a pair -of consecutive cells */ -#define REL_16_16(r) ((r)->type & 0xff00) -#define REL_RELATIVE(r) ((r)->type & 0xff0000) +#define REL_TYPE(r) ((r)->type & 0x000000ff) +#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8) +#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16) /* 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))); diff --git a/native/run.h b/native/run.h index 3120532969..61dc9a1c81 100644 --- a/native/run.h +++ b/native/run.h @@ -1,22 +1,23 @@ #define USER_ENV 32 -#define CARD_OFF_ENV 1 /* for compiling set-slot */ -/* 2 is unused */ -#define NAMESTACK_ENV 3 /* used by library only */ -#define GLOBAL_ENV 4 -#define BREAK_ENV 5 -#define CATCHSTACK_ENV 6 /* used by library only */ -#define CPU_ENV 7 -#define BOOT_ENV 8 -#define CALLCC_1_ENV 9 /* used by library only */ -#define ARGS_ENV 10 -#define OS_ENV 11 -#define ERROR_ENV 12 /* a marker consed onto kernel errors */ -#define IN_ENV 13 -#define OUT_ENV 14 -#define GEN_ENV 15 /* set to gen_count */ -#define IMAGE_ENV 16 /* image name */ -#define CELL_SIZE_ENV 17 /* sizeof(CELL) */ +#define CARD_OFF_ENV 1 /* for compiling set-slot */ +/* 2 is unused */ +#define NAMESTACK_ENV 3 /* used by library only */ +#define GLOBAL_ENV 4 +#define BREAK_ENV 5 +#define CATCHSTACK_ENV 6 /* used by library only */ +#define CPU_ENV 7 +#define BOOT_ENV 8 +#define CALLCC_1_ENV 9 /* used by library only */ +#define ARGS_ENV 10 +#define OS_ENV 11 +#define ERROR_ENV 12 /* a marker consed onto kernel errors */ +#define IN_ENV 13 +#define OUT_ENV 14 +#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];